Macros to combine multiple rows into one

[RSnap3232]

Hello All

is there a macros that can be run to combine all data from multiple rows (which varies) depending on what is in column A as a reference. Using a work laptop so limited to what I can attach but please see below as an example, I want all the Routes for A1 to be on the same row

Route ID	Start	From	To	End	Load Origin	Load Dest
A1	17:15​	Bristol	Gloucester	18:40​	Bristol	Gloucester
A1	19:00​	Gloucester	Ryton	20:30​	Gloucester	Ryton
A1	22:00​	Ryton	Bristol	00:00​	Ryton	Bristol
A22	21:00​	Bristol	Gloucester	22:10​	Bristol	Gloucester
A22	23:00​	Gloucester	Spitfire Road	00:10​	Gloucester	Spitfire Road
A22	01:00​	Spitfire Road	Ryton	01:45​
A22	03:45​	Ryton	Bristol	06:00​	Ryton	Bristol
A22	19:30​	Bristol	Thames Valley	21:15​	Bristol	Thames Valley
A4	23:15​	Thames Valley	Bournemouth	00:45​	Thames Valley	Bournemouth
A4	01:30​	Bournemouth	Thames Valley	03:00​	Bournemouth	Thames Valley
A4	03:45​	Thames Valley	Bristol	05:30​	Thames Valley	Bristol
C4	21:00​	Bristol	Swindon	22:00​	Bristol	Swindon
C4	22:30​	Swindon	Bristol	23:30​	Swindon	Bristol
C4	01:15​	Bristol	Gloucester	02:15​	Bristol	Gloucester
C4	02:45​	Gloucester	Bristol	03:45​	Gloucester	Bristol
C1	21:00​	Bristol	Ryton	23:15​	Bristol	Ryton
C1	03:30​	Ryton	Bristol	05:45​	Ryton	Bristol
C33	19:30​	Bristol	APEC	19:45​
C33	20:30​	APEC	Ryton	22:30​	APEC	Ryton
C33	01:20​	Ryton	Bristol	03:35​	Ryton	Bristol

 

[mumps]

This macro will place the result in Sheet2. Change the sheet names (in red) to suit your needs.

Sub CombineRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, i As Long, v As Variant, rng As Range, x As Long: x = 2
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .Exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                With srcWS
                    .Range("A1").CurrentRegion.AutoFilter 1, v(i, 1)
                    desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1) = v(i, 1)
                    For Each rng In .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
                        With desWS
                            rng.Resize(, 6).Copy .Cells(x, .Columns.Count).End(xlToLeft).Offset(, 1)
                        End With
                    Next rng
                    x = x + 1
                End With
            End If
        Next i
    End With
    desWS.Columns.AutoFit
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

 

[RSnap3232]

This macro will place the result in Sheet2. Change the sheet names (in red) to suit your needs.

Sub CombineRows()
    Application.ScreenUpdating = False
    Dim LastRow As Long, srcWS As Worksheet, desWS As Worksheet, i As Long, v As Variant, rng As Range, x As Long: x = 2
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    v = srcWS.Range("A2", srcWS.Range("A" & Rows.Count).End(xlUp)).Value
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(v, 1)
            If Not .Exists(v(i, 1)) Then
                .Add v(i, 1), Nothing
                With srcWS
                    .Range("A1").CurrentRegion.AutoFilter 1, v(i, 1)
                    desWS.Cells(desWS.Rows.Count, "A").End(xlUp).Offset(1) = v(i, 1)
                    For Each rng In .Range("B2", .Range("B" & .Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
                        With desWS
                            rng.Resize(, 6).Copy .Cells(x, .Columns.Count).End(xlToLeft).Offset(, 1)
                        End With
                    Next rng
                    x = x + 1
                End With
            End If
        Next i
    End With
    desWS.Columns.AutoFit
    srcWS.Range("A1").AutoFilter
    Application.ScreenUpdating = True
End Sub

hello mumps sorry about the delay but that is brilliant thank you, what would I need to change if I need to include columns H, I and J as Ive been forced to add additional columns

 

[Peter_SSs]

Here is another option that you could try. This operates on the active sheet and moves/removes data so test with a copy of your worksheet.

Sub Combine_Rows()
  Dim r As Long
 
  Application.ScreenUpdating = False
  For r = Range("A" & Rows.Count).End(xlUp).Row To 3 Step -1
    If Range("A" & r).Value = Range("A" & r - 1).Value Then
      Range("B" & r, Range("A" & r).End(xlToRight)).Copy Cells(r - 1, Columns.Count).End(xlToLeft).Offset(, 1)
      Rows(r).Delete
    End If
  Next r
  Application.ScreenUpdating = True
End Sub

 

[mumps]

I think that Peter may have given you the solution.

 

[RSnap3232]

Here is another option that you could try. This operates on the active sheet and moves/removes data so test with a copy of your worksheet.

Sub Combine_Rows()
  Dim r As Long
 
  Application.ScreenUpdating = False
  For r = Range("A" & Rows.Count).End(xlUp).Row To 3 Step -1
    If Range("A" & r).Value = Range("A" & r - 1).Value Then
      Range("B" & r, Range("A" & r).End(xlToRight)).Copy Cells(r - 1, Columns.Count).End(xlToLeft).Offset(, 1)
      Rows(r).Delete
    End If
  Next r
  Application.ScreenUpdating = True
End Sub

hello Peter, that has worked a treat thank you.

 

[Peter_SSs]

You're welcome. Glad we could help. Thanks for the follow-up.