إجراء تطابق جدولين في ورقة اكسيل

[aboammar1963]

السادة الأفاضل :

الأساتذة المحترمين

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

تطابق الجدولين.xlsx

[lionheart]

Not so clear but try this code

Sub Test()
    Const sRow As Integer = 4, eRow As Integer = 18
    Dim r As Long, c As Long
    Application.ScreenUpdating = False
        With ActiveSheet
            .Range("B4").CurrentRegion.Sort Key1:=.Range("B4"), Order1:=xlAscending, Header:=xlNo
            .Range("N4").CurrentRegion.Sort Key1:=.Range("N4"), Order1:=xlAscending, Header:=xlNo
            .Rows(sRow & ":" & eRow).Interior.Color = xlNone
            For r = sRow To eRow
                For c = 2 To 12
                    If .Cells(r, c).Value <> .Cells(r, c + 12).Value Then
                        .Cells(r, c).Interior.Color = vbCyan
                        .Cells(r, c + 12).Interior.Color = vbCyan
                    End If
                Next c
            Next r
        End With
    Application.ScreenUpdating = True
End Sub

 

[ابايوسف]

ممكن ترحيل البيانات المطابقة الى شيت اخر

[lionheart]

This is a better version 

If the record doesn't exist in the two tables the record will be colored with yellow and if there are two records with the same id vbCyan will be the color for different information if exists

Sub Test()
    Const sRow As Integer = 4, eRow As Integer = 18
    Dim x, y, r As Long, c As Long
    Application.ScreenUpdating = False
        With ActiveSheet
            .Range("B4").CurrentRegion.Sort Key1:=.Range("B4"), Order1:=xlAscending, Header:=xlNo
            .Range("N4").CurrentRegion.Sort Key1:=.Range("N4"), Order1:=xlAscending, Header:=xlNo
            .Rows(sRow & ":" & eRow).Interior.Color = xlNone
            For r = sRow To eRow
                x = Application.Match(.Cells(r, 2).Value, .Columns(14), 0)
                If Not IsError(x) Then
                    For c = 2 To 12
                        If .Cells(r, c).Value <> .Cells(x, c + 12).Value Then
                            If .Cells(r, c).Interior.Color <> vbYellow Then .Cells(r, c).Interior.Color = vbCyan
                            If .Cells(x, c + 12).Interior.Color <> vbYellow Then .Cells(x, c + 12).Interior.Color = vbCyan
                        End If
                    Next c
                Else
                    .Cells(r, 2).Resize(, 11).Interior.Color = vbYellow
                End If
                y = Application.Match(.Cells(r, 14).Value, .Columns(2), 0)
                If Not IsError(y) Then
                    For c = 2 To 12
                        If .Cells(y, c).Value <> .Cells(r, c + 12).Value Then
                            If .Cells(y, c).Interior.Color <> vbYellow Then .Cells(y, c).Interior.Color = vbCyan
                            If .Cells(r, c + 12).Interior.Color <> vbYellow Then .Cells(r, c + 12).Interior.Color = vbCyan
                        End If
                    Next c
                Else
                    .Cells(r, 14).Resize(, 11).Interior.Color = vbYellow
                End If
            Next r
        End With
    Application.ScreenUpdating = True
End Sub

 

[aboammar1963]

 

 

فائق الاحترام أخي lionheartالمطلوب بالضبط أن يطابق الجدول الثاني الجدول الأول  يعني كل اسم يقابله من الجدول الثاني نفس الاسم

[lionheart]

Sub Test()
    Const sRow As Integer = 4, eRow As Integer = 18
    Dim x, r As Long, cnt As Long
    Application.ScreenUpdating = False
    With ActiveSheet
        For r = sRow To eRow
            cnt = cnt + 1
            x = Application.Match(.Cells(r, 2).Value, .Columns(14), 0)
            If Not IsError(x) Then
                .Cells(x, 14).Resize(, 11).Cut
                If r <> x Then .Cells(r, 14).Insert Shift:=xlDown
            Else
                .Cells(r, 2).Resize(, 11).Cut
                .Cells(.Cells(Rows.Count, 2).End(xlUp).Row + 1, 2).Insert Shift:=xlDown
                If cnt = eRow Then Exit For
                r = r - 1
            End If
        Next r
    End With
    Application.ScreenUpdating = True
End Sub

 

[aboammar1963]

مشكور استاذي الفاضل قلب الأسد