Gather similar data in two tables

Hello everyone

In Sheet1 I have two tables and I need to compare these two tables in another sheet
The logic will be as following:
=====================
Look at the value in column A and if found in Column F then grab the same value in both columns to the same row and so on
As for these similar rows in both tables would be highlighted ...

After all there will be different values in both tables (these will be put beneath each table and sorted in ascending way)

I have put the expected output in Sheets("Output") to give you the final desired result)

Hope it is clear
Thanks advanced for help

Try this. I'm assuming there is only one match for each in column A and F

Sub grouplikes()

Dim lastrow, lastrowa, rownum, currentrow, i As Single
lastrowa = Application.CountA(Range("A:A"))
lastrow = Application.CountA(Range("D:D"))
rownum = 3
currentrow = 3
Do While Range("A" & rownum).Value <> ""
    For i = 3 To lastrow
    If Range("A" & rownum).Value = Range("F" & i).Value Then
        Range("A" & rownum & ":D" & rownum).Copy
        ActiveSheet.Paste Destination:=Worksheets("Output").Range("A" & currentrow)
         Range("A" & rownum & ":D" & rownum).Cut
         ActiveSheet.Paste Destination:=Worksheets("Output").Range("F" & currentrow)
        currentrow = currentrow + 1
        Sheets("Sheet1").Range("F" & i & ":I" & i).ClearContents
        i = lastrow
    End If
    Next i
    rownum = rownum + 1
Loop

Sheets("output").Range("A3:D" & currentrow - 1).Interior.ThemeColor = xlThemeColorAccent5
Sheets("output").Range("F3:I" & currentrow - 1).Interior.ThemeColor = xlThemeColorAccent5
    
Range("A3:D" & lastrowa).Cut
ActiveSheet.Paste Destination:=Worksheets("Output").Range("A" & currentrow)
    
    ActiveWorkbook.Worksheets("Output").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Output").Sort.SortFields.Add Key:=Range("A" & currentrow & ":A" & lastrowa + currentrow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Output").Sort
        .SetRange Range("A" & currentrow & ":D" & lastrowa + currentrow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Range("F3:I" & lastrowa).Cut
ActiveSheet.Paste Destination:=Worksheets("Output").Range("F" & currentrow)
    
    ActiveWorkbook.Worksheets("Output").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Output").Sort.SortFields.Add Key:=Range("F" & currentrow & ":F" & lastrow + currentrow) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Output").Sort
        .SetRange Range("F" & currentrow & ":I" & lastrow + currentrow)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


End Sub

Thanks a lot for reply and for working solution.. But I need to keep original data as it is (original data cleared)

Is it possible to do this task using VBA arrays or dictionary?

If it is possible to do with arrays or dictionaries I'm not aware how.

Maybe :

Sub Test()
  Dim coll As New Collection, arr(), i As Long, j As Long, strKey As String
  With Sheets("Sheet1")
    i = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, .Cells(.Rows.Count, "F").End(xlUp).Row)
    arr = .Range("A3:J" & i).Value
  End With
  For i = 1 To UBound(arr, 1)
      For j = 1 To UBound(arr, 2) Step 5
          If Len(arr(i, j)) Then
             On Error Resume Next
                coll.Add key:=arr(i, j), Item:=New Collection
             On Error GoTo 0
             coll(arr(i, j)).Add Empty
          End If
      Next j
  Next i
  For i = 1 To UBound(arr, 1)
      For j = 1 To UBound(arr, 2) Step 5
          If Len(arr(i, j)) Then
             arr(i, j + 4) = IIf(coll(arr(i, j)).Count = 2, 1, "")
          End If
      Next j
  Next i
  With Sheets("Output")
    .Cells.Clear
    Sheets("Sheet1").Rows(2).Copy .Rows(2)
    With .Range("A3").Resize(UBound(arr, 1), UBound(arr, 2))
      .Value = arr
      .Columns("A:E").Sort key1:=.Columns("E"), order1:=xlAscending, key2:=.Columns("A"), order2:=xlAscending, header:=xlNo
      .Columns("F:J").Sort key1:=.Columns("J"), order1:=xlAscending, key2:=.Columns("F"), order2:=xlAscending, header:=xlNo
      Intersect(.Areas(1), .Columns("E").SpecialCells(xlCellTypeConstants).EntireRow).Interior.Color = 16777164
      .Columns("E").Clear
      .Columns("J").Clear
    End With
  End With
End Sub

Thanks a lot Mr. Omar
Mr. Karedog thank you very much for this awesome solution. You know I am admired of VBA arrays

Just a little point : I don't need to sort similar data .. The sort process will be executed just for the different in the two tables
But as for the similar I need the same order as they were in Sheet1 Column A
Best Regards

Maybe like this ?

Sub Test()
  Dim coll As New Collection, arr(), c As Long, i As Long, j As Long, strKey As String
  With Sheets("Sheet1")
    i = Application.Max(.Cells(.Rows.Count, "A").End(xlUp).Row, .Cells(.Rows.Count, "F").End(xlUp).Row)
    arr = .Range("A3:J" & i).Value
  End With
  For j = 1 To UBound(arr, 2) Step 5
      For i = 1 To UBound(arr, 1)
          If Len(arr(i, j)) Then
             On Error Resume Next
                coll.Add key:=arr(i, j), Item:=New Collection
             On Error GoTo 0
             coll(arr(i, j)).Add Empty
          End If
      Next i
  Next j
  For j = 1 To UBound(arr, 2) Step 5
      For i = 1 To UBound(arr, 1)
          If Len(arr(i, j)) Then
             With coll(arr(i, j))
               If .Count = 2 Then
                  c = c + 1
                  arr(i, j + 4) = Val("1." & Format$(c, "00000"))
                  .Add arr(i, j + 4)
               ElseIf .Count = 3 Then
                  arr(i, j + 4) = .Item(.Count)
               End If
             End With
          End If
      Next i
  Next j
  With Sheets("Output")
    .Cells.Clear
    Sheets("Sheet1").Rows(2).Copy .Rows(2)
    With .Range("A3").Resize(UBound(arr, 1), UBound(arr, 2))
      .Value = arr
      .Columns("A:E").Sort key1:=.Columns("E"), order1:=xlAscending, key2:=.Columns("A"), order2:=xlAscending, header:=xlNo
      .Columns("F:J").Sort key1:=.Columns("J"), order1:=xlAscending, key2:=.Columns("F"), order2:=xlAscending, header:=xlNo
      Intersect(.Areas(1), .Columns("E").SpecialCells(xlCellTypeConstants).EntireRow).Interior.Color = 16777164
      .Columns("E").Clear
      .Columns("J").Clear
    End With
  End With
End Sub

That's really awesome my dear friend.. Thanks a lot for great and wonderful help
Kind regards

You are welcome, thanks for marking the thread as solved and for the rep.points.


Regards