commandos1975 قام بنشر يونيو 17, 2020 مشاركة قام بنشر يونيو 17, 2020 المساعدة في استخراج المكرر في اكتر من عمود مع كتابة اماكن التكرار data.xlsm رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يونيو 17, 2020 مشاركة قام بنشر يونيو 17, 2020 جرب هذا الملف لا لزوم لهذه الكمية من الداتا يكفي 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 3 رابط هذا التعليق شارك More sharing options...
commandos1975 قام بنشر يونيو 17, 2020 الكاتب مشاركة قام بنشر يونيو 17, 2020 شكرا يا غالي علي مجهودك بس المشكة ان الاسماء فعلا كثيرة لا يمكن تصغيرها فهل من طريقة تتعامل وتظهر اماكن المكرر فيها من اسماء الاعمدة سواء الاول او الثاني رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يونيو 17, 2020 مشاركة قام بنشر يونيو 17, 2020 تم التعديل كمكا تريد (التكرار حسب الأعمدة )صفحة 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 1 رابط هذا التعليق شارك More sharing options...
commandos1975 قام بنشر يونيو 18, 2020 الكاتب مشاركة قام بنشر يونيو 18, 2020 شكرا جزيلا الملف الاول افضل من الثاني لكن المطلوب ظهور اسم العمود من اعلي الاول كما بالصورة المرفقة رابط هذا التعليق شارك More sharing options...
أفضل إجابة سليم حاصبيا قام بنشر يونيو 18, 2020 أفضل إجابة مشاركة قام بنشر يونيو 18, 2020 تم معالجة الأمر 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 1 رابط هذا التعليق شارك More sharing options...
abouelhassan قام بنشر يونيو 18, 2020 مشاركة قام بنشر يونيو 18, 2020 ماشاء الله عليك استاذ سليم حفظك الله 1 رابط هذا التعليق شارك More sharing options...
commandos1975 قام بنشر يونيو 19, 2020 الكاتب مشاركة قام بنشر يونيو 19, 2020 ربنا يبارك فيك بتظهر الرسالة دي رابط هذا التعليق شارك More sharing options...
سليم حاصبيا قام بنشر يونيو 19, 2020 مشاركة قام بنشر يونيو 19, 2020 10 دقائق مضت, commandos1975 said: ربنا يبارك فيك بتظهر الرسالة دي لا أعلم ما سبب هذه الرسالة على كل حال انسخ الكود الى ملفك الأصلي ( في موديل مستقل ) وقم يانشاء شيت جديد تحت اسم Final_Sheets و نفذ الكود رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان