Maybe :
Sub Test()
Dim a, i As Long, strKey As String, v1, v2, z As New Collection
Application.DisplayAlerts = False
On Error Resume Next
Sheets("Fa").Delete
On Error GoTo 0
Application.DisplayAlerts = True
Sheets("BD").Copy after:=Sheets("BD")
With ActiveSheet.Range("A1").CurrentRegion
.Parent.Name = "Fa"
For Each v1 In .Parent.Shapes
v1.Delete
Next v1
.Sort key1:=.Columns(2), order1:=xlAscending, key2:=.Columns(3), order2:=xlAscending, Header:=xlYes
a = .Value
For i = 2 To UBound(a, 1)
strKey = a(i, 2) & Chr$(2) & a(i, 3)
On Error Resume Next
z.Add Key:=strKey, Item:=Array(z.Count + 1, New Collection)
On Error GoTo 0
z(strKey)(1).Add i
Next i
i = UBound(a, 1)
ReDim a(1 To i + z.Count, 1 To 1)
a(1, 1) = 0
For Each v1 In z
For Each v2 In v1(1)
a(v2, 1) = v1(0)
Next v2
i = i + 1
a(i, 1) = v1(0)
Next v1
With .Resize(UBound(a, 1), .Columns.Count + 1)
.Columns(.Columns.Count).Value = a
.Sort key1:=.Columns(.Columns.Count), order1:=xlAscending, Header:=xlYes
.Columns(.Columns.Count).ClearContents
End With
End With
End Sub
LinkBack URL
About LinkBacks
Register To Reply
Bookmarks