مقارنة اعمدة معينة على ورقتين

[spyhearts]

السلام عليكم ورحمه الله وبركاته

كل عام واسرة المنتدى العظيم بخير وسعادة 

امل المساعدة في عمل مقارنة بين ورقتين لعدد اعمدة معين 

مرفق الملف الاعندة باللون الاصفر اريد المقارنة بينهم ووضع الاختلافات في ورقة النتائج 

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

مقارنة اعمدة معينة على ورقتين.xlsx

[محمد هشام.]

وعليكم السلام ورحمة الله تعالى وبركاته 

تفضل اخي 

Sub Extract_The_differences()
 '================02/07/2024   by:MOHAMEED HICHAM    www.officena.net     "منتدى الاكسيل" '
'===========================================================================================
    Dim a(1), b, i&, arr&, n&, x&, lr&, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    Dim srcWS As Worksheet: Set srcWS = Sheets("النتائج")
    
    rCrit = [{1,2,12,13,14,18}] ''<=======  ' تحديد اعمدة المقارنة
        
        With Sheets("2023")
        With .Range("a10", .Range("a" & Rows.Count).End(xlUp)).Resize(, 18)
          a(0) = Application.Index(.Value, _
                Evaluate("row(2:" & .Rows.Count & ")"), rCrit)
        End With
    End With
    For i = 1 To UBound(a(0), 1)
        dic(a(0)(i, 1)) = Array(i, Join(Application.Index(a(0), i, 0), Chr(2)))
    Next
    With Sheets("2022")
        With .Range("a10", .Range("a" & Rows.Count).End(xlUp)).Resize(, 18)
            a(1) = Application.Index(.Value, _
            Evaluate("row(2:" & .Rows.Count & ")"), rCrit)
        End With
    End With
    ReDim b(1 To UBound(a(1), 1), 1 To UBound(a(1), 2) * 2 + 2)
    For i = 1 To UBound(a(1), 1)
        If dic.exists(a(1)(i, 1)) Then
            If dic(a(1)(i, 1))(1) <> Join(Application.Index(a(1), i, 0), Chr(2)) Then
                n = n + 1
                For arr = 1 To UBound(a(1), 2)
                    b(n, arr) = a(1)(i, arr)
                    b(n, arr + UBound(b, 2) / 2) = a(0)(dic(a(1)(i, 1))(0), arr)
                    If b(n, arr) <> b(n, arr + UBound(b, 2) / 2) Then
                        b(n, UBound(b, 2)) = b(n, UBound(b, 2)) + 1
                    End If
                Next
            End If
        End If
    Next
    With srcWS
    Application.ScreenUpdating = False
        With .Rows("5:" & .Cells.SpecialCells(11).Row)
            .ClearContents: .Interior.ColorIndex = xlNone
        End With
        If n Then
        .[A5].Resize(n, UBound(b, 2)) = b
            '[تنسيق الاختلافات]
  
        On Error Resume Next
        With .Rows(4).SpecialCells(2).Areas(2)
            With .CurrentRegion.Resize(, .Columns.Count - 1)
                .FormatConditions.Delete
                .FormatConditions.Add 2, Formula1:="=" & .Cells(1).Address(0, 0) & "<>A4"
                .FormatConditions(1).Interior.Color = RGB(255, 204, 0): Set Rng = srcWS.[N5:N1000]
                 On Error GoTo 0
           End With
        End With
    End If
End With
      Application.ScreenUpdating = True
         MsgBox Application.WorksheetFunction.Sum(Rng) & _
         " " & ": عدد الاختلافات", vbInformation, " مقارنة 2022  /  2023 "
End Sub

 

مقارنة اعمدة معينة على ورقتين.xlsm

[spyhearts]

ماشاء الله 

ربنا يبارك في حضرتك ا. محمد هو المطلوب 

ربما يزيدك من علمه ويوفقك في مساعدة الزملاء