Group Contents

 
Sub Group()
    
    Application.ScreenUpdating = False
    Newrow = 1
    Set ws1 = Sheets("R1")
    With ws1
       LastRow = .Range("A" & Rows.Count).End(xlUp).Row
       For RowCount = 1 To LastRow
          A_Data = .Range("A" & RowCount)
          B_Data = .Range("B" & RowCount)
          FirstNewRow = Newrow
          Set c = .Columns("C").Find(what:=A_Data, _
             LookIn:=xlValues, lookat:=xlWhole)
          If Not c Is Nothing Then
             firstAddr = c.Address
             Do
                C_Data = .Range("C" & c.Row)
                D_Data = .Range("D" & c.Row)
                With Sheets("Final")
                   .Range("A" & Newrow) = A_Data
                   .Range("B" & Newrow) = B_Data
                   .Range("C" & Newrow) = C_Data
                   .Range("D" & Newrow) = D_Data
                   Newrow = Newrow + 1
                End With
                Set c = .Columns("C").FindNext(after:=c)
             Loop While Not c Is Nothing And c.Address <> firstAddr
          End If
 
          Set c = .Columns("E").Find(what:=A_Data, _
             LookIn:=xlValues, lookat:=xlWhole)
          If Not c Is Nothing Then
             firstAddr = c.Address
             Do
                E_Data = .Range("E" & c.Row)
                F_Data = .Range("F" & c.Row)
                G_Data = .Range("G" & c.Row)
                With Sheets("Final")
                   If FirstNewRow >= Newrow Then
                      .Range("A" & FirstNewRow) = A_Data
                      .Range("B" & FirstNewRow) = B_Data
                   End If
                   .Range("E" & FirstNewRow) = E_Data
                   .Range("F" & FirstNewRow) = F_Data
                   .Range("G" & FirstNewRow) = G_Data
                   FirstNewRow = FirstNewRow + 1
                End With
                Set c = .Columns("E").FindNext(after:=c)
             Loop While Not c Is Nothing And c.Address <> firstAddr
             If FirstNewRow > Newrow Then
                Newrow = FirstNewRow
             End If
          End If
 
       Next RowCount
    End With
    Application.ScreenUpdating = True
End Sub

I would like to add/adjust this macro so it can do this..


1. Go to Sheet “R1” look at the contents in cell A1 then look for a duplicate of those contents in Column C, Column E, Column G, Column I, Column K, Column M, Column P, and Column S.

2. When Column A has duplicates in
Column C
Column E
Column G
Column I
Column K
Column M
Column P
Column S

I would like to copy that row of..
Columns A plus Column B
Columns C plus Column D
Columns E plus Column F
Columns G plus Column H
Columns I plus Column J
Columns K plus Column L
Columns M plus Column N and Column O
Columns P plus Column Q and Column R
Columns S plus Column T and Column U

3. Then Go to Sheet Final paste those different rows into the same row, so
Column A:B
Column C:D
Column E:F
Column G:H
Column I:J
Column K:L
Column M:O
Column Q:R
Column T:U
Would all be in the same row

4. Go back to Sheet R1 and repeat this process for every cell in Column A

However, Columns M:O, Columns Q:R, and Columns T:U will have duplicates, when that happens I want to put those duplicates under their original occurrence while protecting the entire row

I attached an example of the data before and after, with a lot less rows. Thank you.