عرض البيانات في الليست بوكس بدون تكرار عمود معين

[mohamedamrawy]

السلام عليكم  محتاج كود عرض بيانات في الليست بوكس بدون تكرار عمود معين

[mohamedamrawy]

test2020.xlsm

[سليم حاصبيا]

انا بالحقيقة لا احب ان اتعامل مع اليوزر

لذلك وجدت لك هذه الطريقة(عسى ان تنال الإعجاب)

و هناك مجال اخر للعمل بواسطة الماكرو

الكود

Option Explicit

Sub TEST()
If ActiveSheet.Name <> "Salim" Then Exit Sub
  Dim I%, M%, X%, T%
  Dim arr, nEW_KEY, ky
  Dim Dic  As Object, AL_DIC As Object

  Set Dic = CreateObject("Scripting.Dictionary")
  Set AL_DIC = CreateObject("Scripting.Dictionary")

Range("H3").CurrentRegion.Clear
I = 4
  Do Until Cells(I, 1) = vbNullString
    If Not Dic.EXISTS(Cells(I, 1).Value) Then
      Dic.Add (Cells(I, 1).Value), Cells(I, 2).Value
        Else
      Dic(Cells(I, 1).Value) = Dic(Cells(I, 1).Value) & _
        "*" & Cells(I, 2).Value
    End If
    I = I + 1
  Loop
For Each ky In Dic.KEYS
        arr = Split(Dic.Item(ky), "*")
    For M = LBound(arr) To UBound(arr)
       AL_DIC(arr(M)) = ""
    Next M
 Range("H3").Offset(, T) = ky
    For Each nEW_KEY In AL_DIC
       Range("H3").Offset(X + 1, T) = nEW_KEY
       X = X + 1
    Next nEW_KEY
  AL_DIC.RemoveAll
T = T + 1: X = 0
Next ky
Set AL_DIC = Nothing: Set Dic = Nothing
Erase arr

With Range("H3").CurrentRegion
  .Borders.LineStyle = 1: .InsertIndent 1
  .Font.Size = 14: .Font.Bold = True
  .Interior.ColorIndex = 40
End With

End Sub
  

الملف مرفق

 

My_test2020.xlsm

[mohamedamrawy]

بعد التحية والتقدير للاستاذ سليم اود اشكر حضرتك لتفقدك امري ولك جزيل الشكر ساحاول الاعتماد علي pivot table