Compare Columns

[kate.middleton1]

Hello Everybody,
Is this possible to change the code which is attached with this thread according to the example workbook which is also attached with this thread. Although this code works find for comparing two columns. The detail is also written in workbook about the desired results.

Option Explicit 
 
Sub test2() 
    Dim a, i As Long, w(), e, s$, myArrayList As Object, z(), c, x 
    Application.ScreenUpdating = 0 
    Set myArrayList = CreateObject("System.Collections.Sortedlist") 
    With Sheets(1).Range("a3").CurrentRegion 
        .Copy .Offset(.Rows.Count + 2) 
        a = .Offset(.Rows.Count + 2).CurrentRegion.Value 
        .Offset(.Rows.Count + 2).EntireRow.Delete 
    End With 
    With CreateObject("Scripting.Dictionary") 
        .CompareMode = 1 
        For i = 1 To UBound(a) 
            s = Trim(a(i, 3)) 
            If Not .exists(s) Then 
                .Item(s) = VBA.Array(a(i, 1), a(i, 2), s, a(i, 5), a(i, 7), a(i, 8), Empty) 
            Else 
                myArrayList.Add s, VBA.Array(a(i, 1), a(i, 2), s, a(i, 5), a(i, 7), a(i, 8), Empty) 
            End If 
        Next 
         
        With Sheets(2).Range("a11").CurrentRegion 
            .Copy .Offset(.Rows.Count + 2) 
            a = .Offset(.Rows.Count + 2).CurrentRegion.Value 
            .Offset(.Rows.Count + 2).EntireRow.Delete 
        End With 
         
        For i = 1 To UBound(a, 1) 
            s = Trim(a(i, 3)) 
            If .exists(s) Then 
                 
                w = .Item(s) 
                 
                w(6) = 1 
                .Item(s) = w 
            End If 
        Next 
        For Each e In .keys 
            If IsEmpty(.Item(e)(6)) Then .Remove e 
        Next 
        Sheets(3).Range("a3").Resize(.Count, 6).Value = _ 
        Application.Transpose(Application.Transpose(.items)) 
        For Each e In .keys 
            If myArrayList.Contains(e) Then 
                Sheets(3).Range("a3").Offset(.Count + x).Resize(1, 6).Value = _ 
                Application.Transpose(Application.Transpose(myArrayList.Item(e))) 
                x = x + 1 
            End If 
        Next 
         
    End With 
    Application.ScreenUpdating = 1 
End Sub