اذهب الي المحتوي
أوفيسنا

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

pisces

بواسطه pisces
في منتدى الاكسيل Excel

 مشاركة
إذهب إلى أفضل إجابة Solved by محي الدين ابو البشر,

الردود الموصى بها

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

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

قام بنشر
قام بنشر

ربما 

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

 

  • Like 2
رابط هذا التعليق
شارك
pisces

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
رابط هذا التعليق
شارك
محي الدين ابو البشر

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

قام بنشر
قام بنشر

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

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

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

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

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

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

رابط هذا التعليق
شارك
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

 

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

والله الموفق

تم تعديل بواسطه محي الدين ابو البشر
رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

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



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept