المساعدة في استخراج المكرر في اكتر من عمود

[commandos1975]

المساعدة في استخراج المكرر في اكتر من عمود مع كتابة اماكن التكرار

data.xlsm

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

جرب هذا الملف

لا لزوم لهذه الكمية من الداتا

يكفي 10 -- 15 صف لاختبار الكود

Option Explicit

Sub get_names()
Dim N As Worksheet, D As Worksheet
Dim Dic As Object, Ky, arr
Dim i%, X%, m%: m = 3
Set N = Sheets("names")
Set D = Sheets("Data")
D.Range("c3").CurrentRegion.Clear
Set Dic = CreateObject("Scripting.Dictionary")
For i = 2 To 12 Step 2
 X = 2
 Do Until N.Cells(X, i) = vbNullString
  If Not Dic.Exists(N.Cells(X, i).Value) Then
   Dic(N.Cells(X, i).Value) = N.Cells(X, i).Address
   Else
   Dic(N.Cells(X, i).Value) = Dic(N.Cells(X, i).Value) & "*" & N.Cells(X, i).Address
 End If
  X = X + 1
  Loop
 Next i
 For Each Ky In Dic.keys
  D.Range("D" & m) = Ky
   arr = Split(Dic(Ky), "*")
  D.Range("E" & m).Resize(, UBound(arr) + 1) = arr
  D.Range("C" & m) = UBound(arr) + 1
  m = m + 1
  Next
  With D.Range("C3").CurrentRegion.SpecialCells(2)
  .Borders.LineStyle = 1
  .Font.Size = 16: .Font.Bold = True
  .InsertIndent 1
  .Interior.ColorIndex = 35
  End With
  Set Dic = Nothing
End Sub

الملف مرفق

 

Com_1975.xlsm

[commandos1975]

شكرا يا غالي علي مجهودك بس المشكة ان الاسماء فعلا كثيرة لا يمكن تصغيرها فهل من طريقة تتعامل وتظهر اماكن المكرر فيها من اسماء الاعمدة سواء الاول او الثاني   

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

تم التعديل كمكا تريد (التكرار حسب الأعمدة )صفحة Salim  من هذا الملف 

مع الاجتفاظ بالماكرو السابق في ضفحة Data

Option Explicit

Sub get_names_by_col()
Dim N As Worksheet, SA As Worksheet
Dim Dic As Object, Ky, arr, kyb
Dim i%, X%, m%: m = 5
Dim t%: t = 3

Set N = Sheets("names")
Set SA = Sheets("Salim")
SA.Range("C5").CurrentRegion.Clear
Set Dic = CreateObject("Scripting.Dictionary")

For i = 2 To 12 Step 2
    X = 2
    Do Until N.Cells(X, i) = vbNullString
      If Not Dic.Exists(N.Cells(X, i).Value) Then
        Dic(N.Cells(X, i).Value) = _
        N.Cells(X, i).Address
      Else
        Dic(N.Cells(X, i).Value) = _
        Dic(N.Cells(X, i).Value) & _
        "*" & N.Cells(X, i).Address
      End If
        X = X + 1
    Loop
    If Dic.Count Then
      For Each Ky In Dic.keys
        SA.Cells(m, t) = Ky
        arr = Split(Dic(Ky), "*")
        SA.Cells(m, t + 1) = UBound(arr) + 1
        m = m + 1
      Next Ky
    End If
    t = t + 2: m = 5
    Dic.RemoveAll
Next i
  With SA.Range("C5").CurrentRegion.SpecialCells(2)
  .Borders.LineStyle = 1
  .Font.Size = 16: .Font.Bold = True
  .InsertIndent 1
  .Interior.ColorIndex = 35
  End With
  
  Set Dic = Nothing
  Set N = Nothing: Set SA = Nothing
End Sub

الملف الجديد مرفق

Com_1975_by_columns.xlsm

[commandos1975]

شكرا جزيلا الملف الاول افضل من الثاني لكن المطلوب ظهور اسم العمود من اعلي الاول كما بالصورة المرفقة

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

تم معالجة الأمر

Option Explicit
Dim N As Worksheet, D As Worksheet
Dim F As Worksheet
Dim i%, X%, m%, t%, p%, Ar_name()
Dim My_Rg As Range, Find_rg As Range
'+++++++++++++++++++++++++++++++++++++++++++
Sub get_names()
Dim Dic As Object, Ky, arr
Set N = Sheets("names")
Set D = Sheets("Final_Sheets")
D.Range("C3").CurrentRegion.Clear
Set Dic = CreateObject("Scripting.Dictionary")
m = 3
For i = 2 To 12 Step 2
  X = 2
  Do Until N.Cells(X, i) = vbNullString
    If Not Dic.Exists(N.Cells(X, i).Value) Then
      Dic(N.Cells(X, i).Value) = N.Cells(X, i).Address(0, 0)
    Else
      Dic(N.Cells(X, i).Value) = _
      Dic(N.Cells(X, i).Value) & "*" & N.Cells(X, i).Address(0, 0)
    End If
    X = X + 1
  Loop
Next i

For Each Ky In Dic.keys
  D.Range("D" & m) = Ky
  arr = Split(Dic(Ky), "*")
  D.Range("F" & m).Resize(, UBound(arr) + 1) = arr
  D.Range("C" & m) = UBound(arr) + 1
  m = m + 1
Next
get_column
With D.Range("C3").CurrentRegion.SpecialCells(2)
.Borders.LineStyle = 1
.Font.Size = 16: .Font.Bold = True
.InsertIndent 1
.Interior.ColorIndex = 35
End With

Set Dic = Nothing
End Sub
'+++++++++++++++++++++++++++++++++++++++++++++++
Sub get_column()
Set N = Sheets("names")
Set F = Sheets("Final_Sheets")
X = 3: t = 1
Do Until F.Cells(X, 4) = vbNullString
  For i = 2 To 12 Step 2
      Set My_Rg = N.Cells(1, i).Resize(1000)
      Set Find_rg = My_Rg.Find(F.Cells(X, 4), lookat:=1)
      If Not Find_rg Is Nothing Then
        p = Application.CountIf(My_Rg, F.Cells(X, 4))
      ReDim Preserve Ar_name(1 To t)
      Ar_name(t) = N.Cells(1, i) & ":" & p & " "
    t = t + 1
     End If
  Next i
   If t > 1 Then
   F.Cells(X, 5) = Join(Ar_name, ";")
   End If
    Erase Ar_name: t = 1
    X = X + 1
   Loop

End Sub

الملف مرفق صفحة Final Sheets

 

Com_1975_New.xlsm

[abouelhassan]

ماشاء الله عليك استاذ سليم حفظك الله

[commandos1975]

ربنا يبارك فيك بتظهر الرسالة دي 

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

10 دقائق مضت, commandos1975 said:

ربنا يبارك فيك بتظهر الرسالة دي 

لا أعلم ما سبب هذه الرسالة

على كل حال انسخ الكود الى ملفك الأصلي ( في موديل مستقل )  وقم يانشاء شيت جديد تحت اسم Final_Sheets

و نفذ الكود