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

[Micks578]

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.

 

[Takae]

Hope this helps.

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]

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]

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
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1	Before	PO	Itme	QTY	Ship	Total	Total	Inv	Alloc	B/O		After	PO	Itme	QTY	Ship	Total	Total	Inv	Alloc	B/O
2		A	ZOD	48		96	0	0	0	0			A	ZOD	48		96	0	0	0	0
3		B	ZOD	48					0	0			B	ZOD	48					0	0
4		B	4DU	4		4		#N/A	0	0			B	4DU	4		4		#N/A	0	0
5		B	5DE	4		4		#N/A	0	0			B	5DE	4
6		C	7NO	24		1176		1224	1224	1704			C	7NO	24		1176		1224	1224	1704
7		A	7NO	504		1176		1224	1224	1704			A	7NO	504
8		B	7NO	648		1176		1224	1224	1704			B	7NO	648
9		A	8NOW	240		912		37680	2112	0			A	8NOW	240		912		37680	2112	0
10		B	8NOW	576		912		37680	2112	0			B	8NOW	576
11		D	8NOW	48		912		37680	2112	0			D	8NOW	48
12		E	8NOW	48		912		37680	2112	0			E	8NOW	48
13		A	14UP	240		1056		6642	528	0			A	14UP	240		1056		6642	528	0
14		B	14UP	768		1056		6642	528	0			B	14UP	768
15		D	14UP	48		1056		6642	528	0			D	14UP	48
16		F	7TE	4		28		109	28	12			F	7TE	4		28		109	28	12
17		G	7TE	4		28		109	28	12			G	7TE	4
18		H	7TE	4		28		109	28	12			H	7TE	4
19		I	7TE	8		28		109	28	12			I	7TE	8
20		J	7TE	4		28		109	28	12			J	7TE	4
21		K	7TE	4		28		109	28	12			K	7TE	4
22		L	K42	48		48		11380	384	0			L	K42	48		48		11380	384	0
Sheet2

 

[Micks578]

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
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P	Q	R	S	T	U
1	Before	PO	Itme	QTY	Ship	Total	Total	Inv	Alloc	B/O		After	PO	Itme	QTY	Ship	Total	Total	Inv	Alloc	B/O
2		A	ZOD	48		96	0	0	0	0			A	ZOD	48		96	0	0	0	0
3		B	ZOD	48					0	0			B	ZOD	48					0	0
4		B	4DU	4		4		#N/A	0	0			B	4DU	4		4		#N/A	0	0
5		B	5DE	4		4		#N/A	0	0			B	5DE	4
6		C	7NO	24		1176		1224	1224	1704			C	7NO	24		1176		1224	1224	1704
7		A	7NO	504		1176		1224	1224	1704			A	7NO	504
8		B	7NO	648		1176		1224	1224	1704			B	7NO	648
9		A	8NOW	240		912		37680	2112	0			A	8NOW	240		912		37680	2112	0
10		B	8NOW	576		912		37680	2112	0			B	8NOW	576
11		D	8NOW	48		912		37680	2112	0			D	8NOW	48
12		E	8NOW	48		912		37680	2112	0			E	8NOW	48
13		A	14UP	240		1056		6642	528	0			A	14UP	240		1056		6642	528	0
14		B	14UP	768		1056		6642	528	0			B	14UP	768
15		D	14UP	48		1056		6642	528	0			D	14UP	48
16		F	7TE	4		28		109	28	12			F	7TE	4		28		109	28	12
17		G	7TE	4		28		109	28	12			G	7TE	4
18		H	7TE	4		28		109	28	12			H	7TE	4
19		I	7TE	8		28		109	28	12			I	7TE	8
20		J	7TE	4		28		109	28	12			J	7TE	4
21		K	7TE	4		28		109	28	12			K	7TE	4
22		L	K42	48		48		11380	384	0			L	K42	48		48		11380	384	0
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]

Delete any Error before

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