1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
| Option Explicit
Sub test()
Dim a, i As Long, ii As Long, temp, e, s, w, n As Long, AL As Object, x
Set AL = CreateObject("System.Collections.ArrayList")
CreateSheets "Matched", "Pending"
a = Sheets("10").UsedRange.Value
With CreateObject("Scripting.Dictionary")
.CompareMode = 1: n = 1
For i = 2 To UBound(a, 1)
If a(i, 15) <> "" Then
If Not .exists(a(i, 15)) Then
Set .Item(a(i, 15)) = _
CreateObject("Scripting.Dictionary")
.Item(a(i, 15)).CompareMode = 1
End If
If Not .Item(a(i, 15)).exists(a(i, 4)) Then
ReDim w(1 To 2)
Set w(1) = _
CreateObject("System.Collections.ArrayList")
Set w(2) = _
CreateObject("System.Collections.ArrayList")
.Item(a(i, 15))(a(i, 4)) = w
End If
w = .Item(a(i, 15))(a(i, 4))
w(1).Add a(i, 13): w(2).Add i
.Item(a(i, 15))(a(i, 4)) = w
End If
Next
AL.Add Application.Index(a, 1, 0)
For Each e In .keys
If .Item(e).Count > 1 Then
For i = .Item(e).items()(0)(1).Count - 1 To 0 Step -1
temp = .Item(e).items()(0)(1)(i) * -1
If .Item(e).items()(1)(1).Contains(temp) Then
AL.Add Application.Index(a, .Item(e).items()(0)(2)(i), 0)
x = .Item(e).items()(1)(1).IndexOf(temp, 0)
AL.Add Application.Index(a, .Item(e).items()(i)(2)(x), 0)
.Item(e).items()(0)(1).removeAt i
.Item(e).items()(0)(2).removeAt i
.Item(e).items()(1)(1).Remove temp
.Item(e).items()(1)(2).removeAt x
End If
Next
End If
Next
For Each e In .keys
For Each s In .Item(e).keys
If .Item(e)(s)(1).Count > 0 Then
For i = 0 To .Item(e)(s)(1).Count - 1
n = n + 1
For ii = 1 To UBound(a, 2)
a(n, ii) = a(.Item(e)(s)(2)(i), ii)
Next
Next
End If
Next
Next
End With
With Sheets("pending").Cells(1).Resize(n, UBound(a, 2))
.Parent.UsedRange.ClearContents
.Value = a
.Columns.AutoFit
End With
With Sheets("matched").Cells(1).Resize(AL.Count, UBound(a, 2))
.Parent.UsedRange.ClearContents
.Value = Application.Index(AL.ToArray, 0, 0)
.Columns.AutoFit
End With
End Sub
Private Sub CreateSheets(ByVal matched As String, ByVal pending As String)
On Error Resume Next
If Len(Worksheets(matched).Name) = 0 Then
Sheets.Add(after:=Sheets("10")).Name = matched
End If
If Len(Worksheets(pending).Name) = 0 Then
Sheets.Add(after:=Sheets("10")).Name = pending
End If
On Error GoTo 0
End Sub |
Partager