Option Compare Text
Sub kTest()
Dim dWS As Worksheet, ws As Worksheet, ka, k(), a, c As Long
Dim i As Long, j As Long, S1 As String, S2 As String, aa()
Set dWS = Sheets("0")
ka = dWS.Range("a2:c" & dWS.Range("a" & Rows.Count).End(xlUp).Row)
ReDim k(1 To UBound(ka, 1), 1 To 1)
ReDim aa(1 To UBound(ka, 1), 1 To Columns.Count)
For i = 1 To UBound(ka, 1)
S1 = ka(i, 1) & "|" & ka(i, 2) & "|" & ka(i, 3)
For Each ws In ThisWorkbook.Sheets
If ws.Name <> dWS.Name Then
With ws
a = .UsedRange.Resize(, 17)
For j = 2 To UBound(a, 1)
S2 = a(j, 2)
For c = 13 To 17
If Len(a(j, c)) Then S2 = S2 & "|" & a(j, c)
Next
If S1 = S2 Then
k(i, 1) = k(i, 1) + 1
n = n + 1: aa(i, n) = a(j, 7)
End If
Next
Erase a
End With
End If
Next
Next
With dWS.Range("e2")
.Resize(UBound(ka, 1)).Value = k
.Offset(, 2).Resize(UBound(ka, 1), n).Value = aa
End With
End Sub
|
