جرب هذا الكود
CODE
Option Explicit
Sub Get_unique()
Dim S As Worksheet 'source sheet
Dim T As Worksheet 'target sheet
Dim Rs As Long 'lastrow in target sheet
Dim i As Long, k As Long
Dim d As Object
Dim arr, ky
Dim My_Rg As Range
Application.EnableEvents = False
Set T = Sheets("العمليات")
If T.Range("C6") = vbNullString Then GoTo Exit_sub
Set S = Sheets(T.Range("C6") & "")
Set My_Rg = T.Range("A11").CurrentRegion
If My_Rg.Rows.Count <> 1 Then
My_Rg.Offset(1).Resize(My_Rg.Rows.Count - 1).Clear
End If
Rs = S.Cells(Rows.Count, 2).End(3).Row
If Rs = 1 Then Exit Sub
Set d = CreateObject("scripting.dictionary")
For k = 2 To Rs
If Not d.Exists(S.Cells(k, 2).Value) Then
arr = Application.Transpose(Application.Transpose(S.Cells(k, 3).Resize(, 8)))
arr = Join(arr, "*")
d.Add (S.Cells(k, 2).Value), arr
End If
Next
T.Cells(12, 2).Resize(d.Count - 1) = Application.Transpose(d.Keys)
For Each ky In d.Keys
T.Cells(i + 12, 3).Resize(, 7) = Split(d(ky), "*")
T.Cells(i + 12, 1) = i + 1
i = i + 1
Next
With T.Range("a12").Resize(i, 9)
.Borders.LineStyle = 1
.InsertIndent 1
.Font.Bold = True
.Font.Size = 12
End With
For k = 12 To 11 + i
If T.Range("I" & k) <> vbNullString Then
T.Range("I" & k) = CDate(T.Range("I" & k))
End If
Next
Exit_sub:
Application.EnableEvents = True
End Sub
الملف مرفق