Option Explicit
Sub tt()
Dim a(), b, bb, arr, el, oDict As Object, oDictT As Object, i As Long, t As String, kk
With Application
.DisplayAlerts = False
.ScreenUpdating = False
arr = Array(3, 7, 9)
Set oDict = CreateObject("Scripting.Dictionary")
oDict.comparemode = vbTextCompare
For Each el In arr
With GetObject(ThisWorkbook.Path & "\" & el & ".xlsx")
a = .Sheets(1).[a1].CurrentRegion.Value
.Close 0
End With
Select Case el
Case 3
Set oDictT = CreateObject("Scripting.Dictionary"): oDictT.comparemode = 1
For i = 2 To UBound(a)
If Len(a(i, 2)) Then
oDictT.Item(a(i, 2)) = oDictT.Item(a(i, 2)) + 1
t = a(i, 2) & "|" & oDictT.Item(a(i, 2))
If Not oDict.exists(t) Then
ReDim b(1 To 15)
b(2) = a(i, 2)
b(7) = a(i, 7)
b(8) = a(i, 10)
b(9) = a(i, 9)
b(10) = a(i, 16)
b(12) = a(i, 17)
oDict.Item(t) = b
Else
bb = oDict.Item(t)
bb(2) = a(i, 2)
bb(7) = a(i, 7)
bb(8) = a(i, 10)
bb(9) = a(i, 9)
bb(10) = a(i, 16)
bb(12) = a(i, 17)
oDict.Item(t) = bb
End If
End If
Next
Case 7
Set oDictT = CreateObject("Scripting.Dictionary"): oDictT.comparemode = 1
For i = 2 To UBound(a)
If Len(a(i, 8)) Then
oDictT.Item(a(i, 8)) = oDictT.Item(a(i, 8)) + 1
t = a(i, 8) & "|" & oDictT.Item(a(i, 8))
If Not oDict.exists(t) Then
ReDim b(1 To 15)
b(2) = a(i, 8)
b(13) = a(i, 10)
oDict.Item(t) = b
Else
bb = oDict.Item(t)
bb(2) = a(i, 8)
bb(13) = a(i, 10)
oDict.Item(t) = bb
End If
End If
Next
Case 9
Set oDictT = CreateObject("Scripting.Dictionary"): oDictT.comparemode = 1
For i = 2 To UBound(a)
If Len(a(i, 6)) Then
oDictT.Item(a(i, 6)) = oDictT.Item(a(i, 6)) + 1
t = a(i, 6) & "|" & oDictT.Item(a(i, 6))
If Not oDict.exists(t) Then
ReDim b(1 To 15)
b(1) = a(i, 5)
b(2) = a(i, 6)
b(3) = a(i, 13)
b(4) = a(i, 15)
b(5) = a(i, 11)
b(15) = a(i, 22)
oDict.Item(t) = b
Else
bb = oDict.Item(t)
bb(1) = a(i, 5)
bb(2) = a(i, 6)
bb(3) = a(i, 13)
bb(4) = a(i, 15)
bb(5) = a(i, 11)
bb(15) = a(i, 22)
oDict.Item(t) = bb
End If
End If
Next
End Select
Next
With ThisWorkbook.Sheets(1)
i = 4
bb = oDict.keys
SortArray bb
For Each kk In bb
i = i + 1
b = oDict.Item(kk)
With Cells(i, 3).Resize(, UBound(b))
.Columns(1).NumberFormat = "@"
.Value = b
End With
Next
'.Cells.EntireColumn.AutoFit
End With
.DisplayAlerts = True
.ScreenUpdating = True
End With
End Sub
Private Sub SortArray(ByRef a As Variant)
Dim i As Long, j As Long
Dim t As Variant
'standard bubble sort loops
For i = LBound(a) To UBound(a) - 1
For j = i + 1 To UBound(a)
If a(i) > a(j) Then 'change to < for descending order
t = a(i)
a(i) = a(j)
a(j) = t
End If
Next j
Next i
End Sub
|
Дальше уже ТС обдумает и сообщит, что нужно поправить.