Vba: merge like rows by column if value of another column is same.

Micks578

New Member
Joined
Jan 25, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
In the attached, you have the before and after data.

I basically looked at any ITEMS in column B that had the same name and merged the rows for those ITEMS in Column E, then did another merge for the same rows for column F, and did the same type of merging for Columns G, H, and I.

The amount of rows can be more or less depending on the day so the macro must adjust for that as well.

Any help creating such a macro would be greatly appreciated since merging manually can be tedious and easily cause mistakes.

Thank you.
 

Attachments

  • Help - Excel 1_25_2021 12_56_57 AM.png
    Help - Excel 1_25_2021 12_56_57 AM.png
    87.4 KB · Views: 21

Some videos you may like

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.

Takae

Well-known Member
Joined
Jul 1, 2015
Messages
723
Hope this helps.
VBA Code:
Sub test()
Dim ws1 As Worksheet, Tws As Worksheet
Dim LR As Long, cnt As Long, i As Long

Set ws1 = Sheets("Sheet1")
Set Tws = Sheets("Sheet2")
Application.ScreenUpdating = False
LR = ws1.Cells(Rows.Count, 1).End(xlUp).Row

With Tws
    .Range(.Range("A1"), .Range("A1").SpecialCells(xlLastCell)).MergeCells = False
    .Range(.Range("A1"), .Range("A1").SpecialCells(xlLastCell)).ClearContents
    .Range(.Range("A1"), .Range("A1").SpecialCells(xlLastCell)).Borders.LineStyle = False
    ws1.Range(ws1.Range("A1"), ws1.Cells(LR, 9)).Copy .Range("A1")
   
    Application.DisplayAlerts = False
    For i = 2 To LR
        If .Cells(i, 2).Value = .Cells(i + 1, 2).Value Then
            cnt = cnt + 1
        Else
            If cnt > 0 Then
                .Range(.Cells(i - cnt, 5), .Cells(i, 5)).Merge
                .Range(.Cells(i - cnt, 6), .Cells(i, 6)).Merge
                .Range(.Cells(i - cnt, 7), .Cells(i, 7)).Merge
                .Range(.Cells(i - cnt, 8), .Cells(i, 8)).Merge
                .Range(.Cells(i - cnt, 9), .Cells(i, 9)).Merge
            End If
            cnt = 0
        End If
    Next
    Application.DisplayAlerts = True
    .Range(.Range("A1"), .Cells(LR, 9)).Borders.LineStyle = True
End With
Application.ScreenUpdating = true
End Sub
 

Dossfm0q

Banned User
Joined
Mar 9, 2009
Messages
570
Office Version
  1. 2019
Platform
  1. Windows
VBA Code:
Sub merge_like_rows_by_column()
Dim Tbl As Range, Rng As Range, Cll As Range
Set Tbl = Range("B1").CurrentRegion
Set Rng = Tbl.Columns(5).Resize(Tbl.Rows.Count, 4).Cells
    For Each Cll In Rng
    
        With Cll
            For N = 1 To Rng.Rows.Count
                If Cll.Offset(N, 0).Value = .Value And .Value <> "" Then
                Cll.Offset(N, 0).Value = ""
                Else
                Cll.Resize(N, 1).Merge
                Exit For
                End If
            Next
        End With
    
    Next
End Sub
 

Dossfm0q

Banned User
Joined
Mar 9, 2009
Messages
570
Office Version
  1. 2019
Platform
  1. Windows
Code:
Sub merge_like_rows_by_column()

Application.ScreenUpdating = False
Dim CpyRng As Range, DstnRng As Range
Dim Tbl As Range, Rng As Range, Cll As Range

Set CpyRng = Range("A1").CurrentRegion
Set DstnRng = Cells(CpyRng.Row, CpyRng.Column + CpyRng.Columns.Count + 1)
CpyRng.Copy Destination:=DstnRng

Set Tbl = DstnRng.Cells(1, 1).CurrentRegion
Set Rng = Tbl.Columns(6).Cells

   For Each Cll In Rng
  
        With Cll
            For N = 1 To Rng.Rows.Count
                If Cll.Offset(N, 0).Value = .Value And .Value <> "" Then
                    For c = 0 To 4
                        Cll.Offset(0, c).Offset(N, 0).Value = ""
                    Next
                Else
                    For c = 0 To 4
                        Cll.Offset(0, c).Resize(N, 1).Merge
                    Next
                Exit For
                End If
            Next
        End With
    Next
  
    With Tbl
    .Cells(1, 1).Orientation = xlVertical
    .Borders.LineStyle = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Replace "Before", "After"
    End With
Application.ScreenUpdating = True

End Sub

Book1
ABCDEFGHIJKLMNOPQRSTU
1BeforePOItmeQTYShipTotalTotalInvAllocB/OAfterPOItmeQTYShipTotalTotalInvAllocB/O
2AZOD48960000AZOD48960000
3BZOD4800BZOD4800
4B4DU44#N/A00B4DU44#N/A00
5B5DE44#N/A00B5DE4
6C7NO241176122412241704C7NO241176122412241704
7A7NO5041176122412241704A7NO504
8B7NO6481176122412241704B7NO648
9A8NOW2409123768021120A8NOW2409123768021120
10B8NOW5769123768021120B8NOW576
11D8NOW489123768021120D8NOW48
12E8NOW489123768021120E8NOW48
13A14UP240105666425280A14UP240105666425280
14B14UP768105666425280B14UP768
15D14UP48105666425280D14UP48
16F7TE4281092812F7TE4281092812
17G7TE4281092812G7TE4
18H7TE4281092812H7TE4
19I7TE8281092812I7TE8
20J7TE4281092812J7TE4
21K7TE4281092812K7TE4
22LK424848113803840LK424848113803840
Sheet2
 
Last edited:

Micks578

New Member
Joined
Jan 25, 2021
Messages
2
Office Version
  1. 365
Platform
  1. Windows
Code:
Sub merge_like_rows_by_column()

Application.ScreenUpdating = False
Dim CpyRng As Range, DstnRng As Range
Dim Tbl As Range, Rng As Range, Cll As Range

Set CpyRng = Range("A1").CurrentRegion
Set DstnRng = Cells(CpyRng.Row, CpyRng.Column + CpyRng.Columns.Count + 1)
CpyRng.Copy Destination:=DstnRng

Set Tbl = DstnRng.Cells(1, 1).CurrentRegion
Set Rng = Tbl.Columns(6).Cells

   For Each Cll In Rng
 
        With Cll
            For N = 1 To Rng.Rows.Count
                If Cll.Offset(N, 0).Value = .Value And .Value <> "" Then
                    For c = 0 To 4
                        Cll.Offset(0, c).Offset(N, 0).Value = ""
                    Next
                Else
                    For c = 0 To 4
                        Cll.Offset(0, c).Resize(N, 1).Merge
                    Next
                Exit For
                End If
            Next
        End With
    Next
 
    With Tbl
    .Cells(1, 1).Orientation = xlVertical
    .Borders.LineStyle = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Replace "Before", "After"
    End With
Application.ScreenUpdating = True

End Sub

Book1
ABCDEFGHIJKLMNOPQRSTU
1BeforePOItmeQTYShipTotalTotalInvAllocB/OAfterPOItmeQTYShipTotalTotalInvAllocB/O
2AZOD48960000AZOD48960000
3BZOD4800BZOD4800
4B4DU44#N/A00B4DU44#N/A00
5B5DE44#N/A00B5DE4
6C7NO241176122412241704C7NO241176122412241704
7A7NO5041176122412241704A7NO504
8B7NO6481176122412241704B7NO648
9A8NOW2409123768021120A8NOW2409123768021120
10B8NOW5769123768021120B8NOW576
11D8NOW489123768021120D8NOW48
12E8NOW489123768021120E8NOW48
13A14UP240105666425280A14UP240105666425280
14B14UP768105666425280B14UP768
15D14UP48105666425280D14UP48
16F7TE4281092812F7TE4281092812
17G7TE4281092812G7TE4
18H7TE4281092812H7TE4
19I7TE8281092812I7TE8
20J7TE4281092812J7TE4
21K7TE4281092812K7TE4
22LK424848113803840LK424848113803840
Sheet2
Thank you for the attempt. Seems to be on the right track. Let me clarify the excel sheet a little more to tailor this macro:

1) Only those rows with the SAME Item name for column F, G, H, I, J are merged For example, in my attached sheet, there are two "2DD" items which column F, G, H, I, and J, for those rows are merged. The QTY isn't what triggers the merge, it's the same item name.
2) On the same note, there are three "7NO" items, all three have different QTY that add up to 1176 total order. But all three rows in column F, G, H, I, and J are merged because it's the same Item Name "7NO."
3) In your example, it didn't complete the merge in the first similar item "ZOD" for columns H, I, and J, AND more importantly, it merged items 4DU and 5DE which are not the same items, even though they had similar QTY.

So to summarize, I only need columns F, G, H, I and J merged ONLY for those rows where the item is the same. And lastly, the merged cells don't need to be copied to the right, they can just be corrected on the original data. I only copied to show the difference between before and after.
 

Dossfm0q

Banned User
Joined
Mar 9, 2009
Messages
570
Office Version
  1. 2019
Platform
  1. Windows
Delete any Error before
VBA Code:
Sub merge_like_rows_by_column()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim CpyRng As Range, DstnRng As Range
Dim Tbl As Range, Rng As Range, Cll As Range

Set CpyRng = Range("A1").CurrentRegion
Set DstnRng = Cells(CpyRng.Row, CpyRng.Column + CpyRng.Columns.Count + 1)
CpyRng.Copy Destination:=DstnRng

Set Tbl = DstnRng.Cells(1, 1).CurrentRegion


For c = 6 To 10 '<<<<<<<<<<<<<< is you need
Set Rng = Tbl.Columns(c).Cells
   For Each Cll In Rng
 
        With Cll
            For N = 1 To Rng.Rows.Count
           On Error Resume Next
                If Cll.Offset(N, 0).Value = .Value And .Value <> "" And Cells(Cll.Row, Cll.Column - c + 3).Offset(N, 0) = Cells(Cll.Row, Cll.Column - c + 3).Value Then
                    Cll.Offset(N, 0).Value = ""
                Else
                    Cll.Resize(N, 1).Merge
                Exit For
             End If
             On Error GoTo 0
            Next N
            
        End With
    Next ' Each Cll
Next c
 
    With Tbl
    .Cells(1, 1).Orientation = xlVertical
    .Borders.LineStyle = True
    .HorizontalAlignment = xlCenter
    .VerticalAlignment = xlCenter
    .Replace "Before", "After"
    End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,127,107
Messages
5,622,780
Members
415,927
Latest member
vedasinternational

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top