طلب لمساعدتي في كود VBA

[pisces]

طلب لمزامنة الادخال من ورقتين في ورقة واحدة مع الترتيب 

مثال

Book1.xlsM

[محي الدين ابو البشر]

ربما

Sub test()
    With Sheets("B")
        a = Join(Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))))
        b = Join(Application.Transpose(.Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))))
    End With
    With Sheets("C")
        a1 = Join(Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))))
        b1 = Join(Application.Transpose(.Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))))
    End With
    a = Split(a & " " & a1): b = Split(b & " " & b1)
    With CreateObject("scripting.dictionary")
        For i = 0 To UBound(a)
            If Not .exists(a(i)) Then .Add a(i), b(i)
        Next
        a = Application.Transpose(Array(.keys, .items))
    End With
    Sheets("A").Cells(2, 1).Resize(UBound(a), 2) = a
    With Worksheets("A").Sort
        Worksheets("A").Sort.SortFields.Clear
        Worksheets("A").Sort.SortFields.Add2 Key:=Range("A2:A" & UBound(a) + 1), _
                                             SortOn:=xlSortOnValues, Order:=xlAscending
        .SetRange Range("A2:b" & UBound(a) + 1)
        .Header = xlGuess
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
End Sub

 

[pisces]

السلام عليكم

 

شكرا" للأخ محي الدين ابو البشر للمساعدة 

أنا لس خبير في Excel لذلك لم استطع استخدام الكود 

ارجو منكم تثبيته على الملف المرفق 

مع الشكر الجزيل

[محي الدين ابو البشر]

Book1 (2).xlsM

[pisces]

يعطيك الف عافية عزيزي محي الدين ابو البشر

تشتغل ويطلع ERROR

اذا امكن تعرف لي الخلل وين وعندي كود من النت اذا تتأكد يخدمني او لا

 

Sub compair_columns()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim a As Variant, b As Variant, v As Variant
  Dim dic As Object, i As Long, cad As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh1 = Sheets("Sheet1")
  Set sh2 = Sheets("Sheet2")
  Set sh3 = Sheets("Sheet3")
  
  Set dic = CreateObject("Scripting.Dictionary")
  a = sh1.Range("A2:G" & sh1.Range("A" & Rows.Count).End(xlUp).Row).Value2
  b = sh2.Range("A2:G" & sh2.Range("A" & Rows.Count).End(xlUp).Row).Value2
  
  dic("exist in A and not in B") = "exist in A and not in B"
  For i = 1 To UBound(a, 1)
    cad = a(i, 1) & "|" & a(i, 2) & "|" & a(i, 3) & "|" & a(i, 4) & "|" & a(i, 5) & "|" & a(i, 6) & "|" & a(i, 7)
    dic(LCase(cad)) = cad
  Next
  
  dic("exist in B and not in A") = "exist in B and not in A"
  For i = 1 To UBound(b, 1)
    cad = b(i, 1) & "|" & b(i, 2) & "|" & b(i, 3) & "|" & b(i, 4) & "|" & b(i, 5) & "|" & b(i, 6) & "|" & b(i, 7)
    If dic.exists(LCase(cad)) Then
      dic.Remove LCase(cad)
    Else
      dic(LCase(cad)) = cad
    End If
  Next
  sh3.Range("A2").Resize(dic.Count, 1).Value = Application.Transpose(dic.items)
  sh3.Range("A2:A" & dic.Count + 1).TextToColumns Destination:=sh3.Range("A2"), OtherChar:="|"
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

[pisces]

السلام عليكم  ... ارجو منكم اكتشاف الخلل

 Worksheets("A").Sort.SortFields.Add2 Key:=Range("A2:A" & UBound(a) + 1), _
                                             SortOn:=xlSortOnValues, Order:=xlAscending

 

[محي الدين ابو البشر]

 عليكم السلام أخي الكريم

بالنسبة للكود الذي قدمته لك يعمل جيداً عندي !!!

لا أدري ماذا يحصل عندك

بالسبة للكود يمكن أن يخدمك بعد التعديل ليصبح

Sub compair_columns()
  Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim a As Variant, b As Variant, v As Variant
  Dim dic As Object, i As Long, cad As String
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set sh1 = Sheets("B")
  Set sh2 = Sheets("C")
  Set sh3 = Sheets("A")
  
  Set dic = CreateObject("Scripting.Dictionary")
  a = sh1.Range("A2:b" & sh1.Range("A" & Rows.Count).End(xlUp).Row).Value2
  b = sh2.Range("A2:b" & sh2.Range("A" & Rows.Count).End(xlUp).Row).Value2
  
'  dic("exist in A and not in B") = "exist in A and not in B"
  For i = 1 To UBound(a, 1)
    cad = a(i, 1) & "|" & a(i, 2)
    dic(LCase(cad)) = cad
  Next
  
'  dic("exist in B and not in A") = "exist in B and not in A"
  For i = 1 To UBound(b, 1)
    cad = b(i, 1) & "|" & b(i, 2)
    If Not dic.exists(LCase(cad)) Then
           dic(LCase(cad)) = cad
    End If
  Next
  sh3.Range("A2").Resize(dic.Count).Value = Application.Transpose(dic.items)
  sh3.Range("A2:A" & dic.Count + 1).TextToColumns Destination:=sh3.Range("A2"), OtherChar:="|", FieldInfo:=Array(Array(2, 1))
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

لكنه بحاجة لإضافة كود للفرز

[محي الدين ابو البشر]

وهذا خيار آخر

Book1 (2) (1).xlsM

[pisces]

السلام عليكم 

اقدم جزيل الشكر والامتنان للأخ محي الدين ابو البشر على مساعدته لي

 

[pisces]

 

السلام عليكم

في العمود الثاني غالبا" ما تختلف الاسماء لا اعلم هل يأخذ الكود من ورقه والاسم من ورقه أخرى؟؟؟

وهل بإستطاعتي إضافة ورقه أخرى "D" لتظهر النتيجة لثلاث ورقات وليست ورقتين؟

 

Book1 (2) (1) (3).xlsM

 

وشكراً

 

 

[محي الدين ابو البشر]

أخي العزيز

إليك خيارين

الأول إضافة ورقة باسم D كما في الملف الذي ارسلته

Sub test()
    Dim a, b, a1, b1, c, c1
    Dim i As Long
    Dim j As Long
    Dim temp
    With Sheets("B")
        a = Join(Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))), "#")
        b = Join(Application.Transpose(.Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))), "#")
    End With
    With Sheets("C")
        a1 = Join(Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))), "#")
        b1 = Join(Application.Transpose(.Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))), "#")
    End With
    With Sheets("D")
        c = Join(Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))), "#")
        c1 = Join(Application.Transpose(.Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))), "#")
    End With
    a = Split(a & "#" & a1, "#"): b = Split(b & "#" & b1, "#"): c = Split(c & "#" & c1, "#")
    With CreateObject("scripting.dictionary")
        For i = 0 To UBound(a)
            If Not .exists(a(i)) Then .Add a(i), b(i)
        Next
        a = Application.Transpose(Array(.keys, .items))
    End With
    Sheets("A").Cells(2, 1).Resize(UBound(a), 2) = a
    For i = 1 To (UBound(a, 1) - 1)
        For j = i To UBound(a, 1)
            If Val(a(j, 1)) < Val(a(i, 1)) Then
                temp = a(i, 1): a(i, 1) = a(j, 1): a(j, 1) = temp
                temp = a(i, 2): a(i, 2) = a(j, 2): a(j, 2) = temp
            End If
        Next j: Next i
    Sheets("A").Cells(2, 1).Resize(UBound(a), 2) = a
End Sub

والخيار الثاني يمكنادمج أي  عدد من الأوراق إلى الورقة الحالية( الموجود فيها زر الدمج

Sub test1()
    Dim a, b, c, c1
    Dim i As Long
    Dim j As Long
    Dim temp
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> ActiveSheet.Name Then
            With Sheets(i)
                a = Join(Application.Transpose(.Range(.Cells(2, 1), .Cells(2, 1).End(xlDown))), "#")
                b = Join(Application.Transpose(.Range(.Cells(2, 2), .Cells(2, 2).End(xlDown))), "#")
            End With
            c = IIf(c = "", a, c & "#" & a): c1 = IIf(c1 = "", b, c1 & "#" & b)
        End If
    Next
    c = Split(c, "#"): c1 = Split(c1, "#")
    With CreateObject("scripting.dictionary")
        For i = 0 To UBound(c)
            If Not .exists(c(i)) Then .Add c(i), c1(i)
        Next
        a = Application.Transpose(Array(.keys, .items))
    End With
    For i = 1 To (UBound(a, 1) - 1)
        For j = i To UBound(a, 1)
            If Val(a(j, 1)) < Val(a(i, 1)) Then
                temp = a(i, 1): a(i, 1) = a(j, 1): a(j, 1) = temp
                temp = a(i, 2): a(i, 2) = a(j, 2): a(j, 2) = temp
            End If
        Next j: Next i
    ActiveSheet.Cells(2, 1).Resize(UBound(a), 2) = a
End Sub

 

بالمناسبة الأسماء في العمود الأول يجب أن تكون متطابقة حتى الفراغات بعد أو قبل الاسم يعتبر اسم جديد

والله الموفق

تم تعديل مارس 2, 2022 بواسطه محي الدين ابو البشر

[pisces]

السلام عليكم

شكراً لك اخي العزيز 

أنا أفضل الكود الأول فقد عجبني ولكن لا اعرف لماذا لا يعمل معي

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

اتمنى لك دوام التوفيق والنجاح

[محي الدين ابو البشر]

Book1 (2) (1) (3) (1).xlsM

[pisces]

شكراً جزيلاً اخي الكريم

 

الورقة "D" لا تدخل معهم

[محي الدين ابو البشر]

Book1 (2) (1) (3) (1).xlsM

 

دخلت

[pisces]

شكراً لك اخي الكريم على هذا المجهود الاكثر من رائع