VBA to consolidate multiple rows with like-data into a single row

[Bigred251]

Hello - I'm hoping someone can help me. What i'm trying to do is be able to execute a macro that would look at data in a table similar to the example below and consolidate so that multiple rows with the same Ship Date/Vendor/Order Type/Plant and Material would display in a single row with the quantity summed (much like a pivot table would do). The table is limited to these 6 columns, but there could be no limit to the number of rows. I'd prefer to stay away from pivot table as I need a nice clean presentation for the end user. Any help would be GREATLY appreciated!!!

For example: The table below (Rows 1 - 5) could be summarized/consolidated into 3 rows of data(Rows 7 - 10)

	A	B	C	D	E	F
1	Ship Date	Vendor	Order Type	Plant	Material	Quantity
2	6/22/2015	300868	ZOR	1001	1536	20
3	6/22/2015	300868	ZOR	1001	1536	30
4	7/15/2015	300862	ZDIS	1006	266321	60
5	6/22/2015	300868	ZOR	1005	1536	40
6
7	Ship Date	Vendor	Order Type	Plant	Material	Quantity
8	6/22/2015	300868	ZOR	1001	1536	50
9	6/22/2015	300868	ZOR	1005	1536	40
10	7/15/2015	300862	ZDIS	1006	266321	60

<tbody>
</tbody>

 

[hiker95]

Bigred251,

Welcome to the MrExcel forum.

1. What version of Excel, and, Windows are you using?

2. Are you using a PC or a Mac?

Here is a macro solution for you to consider, based on your posted data, and, the original data will be replaced with the results.


If you do not want the results to replace the original data, I can re-write the macro so that the original data will stay where it is, and, the results will be written to columns H thru M.


You can change the raw data worksheet name in the macro.

Sample raw data:

Excel 2007
	A	B	C	D	E	F
1	Ship Date	Vendor	Order Type	Plant	Material	Quantity
2	6/22/2015	300868	ZOR	1001	1536	20
3	6/22/2015	300868	ZOR	1001	1536	30
4	7/15/2015	300862	ZDIS	1006	266321	60
5	6/22/2015	300868	ZOR	1005	1536	40
6
Sheet1

After the macro:

Excel 2007
	A	B	C	D	E	F
1	Ship Date	Vendor	Order Type	Plant	Material	Quantity
2	6/22/2015	300868	ZOR	1001	1536	50
3	6/22/2015	300868	ZOR	1005	1536	40
4	7/15/2015	300862	ZDIS	1006	266321	60
5
6
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ConsolidateData()
' hiker95, 07/03/2015, ME865785
Dim lr As Long, r As Long, n As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")   '<-- you can change the sheet name here
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  With .Range("G2:G" & lr)
    .Formula = "=A2&B2&C2&D2&E2"
    .Value = .Value
  End With
  .Range("A2:G" & lr).Sort key1:=.Range("G2"), order1:=1
  For r = 2 To lr
    n = Application.CountIf(.Columns(7), .Cells(r, 7).Value)
    If n > 1 Then
      .Range("F" & r).Value = Evaluate("=Sum(F" & r & ":F" & r + n - 1 & ")")
      .Range("A" & r + 1 & ":F" & r + n - 1).ClearContents
    End If
    r = r + n - 1
  Next r
  .Range("G2:G" & lr).ClearContents
  .Range("A2:F" & lr).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ConsolidateData macro.

 

[Bigred251]

Thank you for your help! Quick question: would there be a drastic difference in code if I wanted to consilidate the table data into a new sheet in the same workbook? Meaning take the data in sheet1 and consildate and display in sheet 2?

 

[hiker95]

Thank you for your help!

Bigred251,

Thanks for the feedback.

You are very welcome. Glad I could help.

would there be a drastic difference in code if I wanted to consilidate the table data into a new sheet in the same workbook? Meaning take the data in sheet1 and consildate and display in sheet 2?

1. Sheet2 works for me.

2. Or, how about a new worksheet name, like, Results?

 

[Bigred251]

Yes "Results" would be great. Do I just need to rename a sheet "Results" and replace "sheet 1" in your code with "results"?

 

[hiker95]

Bigred251,

Here is another macro for you to consider based on your latest request.

You can change the raw data worksheet name in the macro.

Sample raw data in worksheet Sheet1:

Excel 2007
	A	B	C	D	E	F
1	Ship Date	Vendor	Order Type	Plant	Material	Quantity
2	6/22/2015	300868	ZOR	1001	1536	20
3	6/22/2015	300868	ZOR	1001	1536	30
4	7/15/2015	300862	ZDIS	1006	266321	60
5	6/22/2015	300868	ZOR	1005	1536	40
6
Sheet1

After the macro in a new worksheet Results:

Excel 2007
	A	B	C	D	E	F
1	Ship Date	Vendor	Order Type	Plant	Material	Quantity
2	6/22/2015	300868	ZOR	1001	1536	50
3	6/22/2015	300868	ZOR	1005	1536	40
4	7/15/2015	300862	ZDIS	1006	266321	60
5
Results

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

Sub ConsolidateDataV2()
' hiker95, 07/04/2015, ME865785
Dim w1 As Worksheet, wr As Worksheet
Dim lr As Long, r As Long, n As Long
Application.ScreenUpdating = False
Set w1 = Sheets("Sheet1")   '<-- you can change the sheet name here
lr = w1.Cells(Rows.Count, 1).End(xlUp).Row
If Not Evaluate("ISREF(Results!A1)") Then Worksheets.Add(After:=w1).Name = "Results"
Set wr = Sheets("Results")
wr.UsedRange.ClearContents
w1.Range("A1:F" & lr).Copy wr.Cells(1, 1)
Application.CutCopyMode = False
With wr
  .Activate
  With .Range("G2:G" & lr)
    .Formula = "=A2&B2&C2&D2&E2"
    .Value = .Value
  End With
  .Range("A2:G" & lr).Sort key1:=.Range("G2"), order1:=1
  For r = 2 To lr
    n = Application.CountIf(.Columns(7), .Cells(r, 7).Value)
    If n > 1 Then
      .Range("F" & r).Value = Evaluate("=Sum(F" & r & ":F" & r + n - 1 & ")")
      .Range("A" & r + 1 & ":F" & r + n - 1).ClearContents
    End If
    r = r + n - 1
  Next r
  .Range("G2:G" & lr).ClearContents
  .Range("A2:F" & lr).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
  .UsedRange.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ConsolidateDataV2 macro.

 

[Bigred251]

My sincere thanks for your time. This was a tremendous help!

 

[hiker95]

Bigred251,

Thanks for the feedback.

You are very welcome. Glad I could help.

And, come back anytime.

 

[ocvmelbye]

Hi,

I have tried modified this on my own, but not big luck.

In row A i have names of different tiles. In row b i have total sq meters.

<colgroup><col><col></colgroup><tbody>
</tbody>

<tbody>
</tbody>

30x60	16,2
25x40	16,2
Michigan 20x40 Beige	285,2
Michigan 20x40 Beige	44,9
Michigan 20x40 Tabaco	405,6
Michigan 20x40 Marengo	18,2
Michigan 20x40 Beige	65,8
25x40	625,2

<colgroup><col><col></colgroup><tbody>
</tbody>

I want to remove all duplicats, but value should be added to the duplicate. Meaning in this example:
25x40 is there two times. Then remove 25x40 once and value in row b for 25x40 should be 16,2 x 625,2 = 641,4

This is my code now:

Dim lr As Long, r As Long, n As Long
Application.ScreenUpdating = False
With Sheets("SortData")   '<-- you can change the sheet name here
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  With .Range("C2:C" & lr)
    .Formula = "=A2"
    .Value = .Value
  End With
  .Range("A2:C" & lr).Sort key1:=.Range("C2"), order1:=1
  For r = 2 To lr
    n = Application.CountIf(.Columns(3), .Cells(r, 3).Value)
    If n > 1 Then
      .Range("B" & r).Value = Evaluate("=Sum(B" & r & ":B" & r + n - 1 & ")")
      .Range("A" & r + 1 & ":B" & r + n - 1).ClearContents
    End If
    r = r + n - 1
  Next r
  .Range("C2:C" & lr).ClearContents
  .Range("A2:B" & lr).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
End With
Application.ScreenUpdating = True

End Sub

 

[hiker95]

ocvmelbye,

If I understand you correctly, then here is a new macro solution for you to consider that is based on your flat text display.

You can change the raw data worksheet name in the macro.

Sample raw data:

Excel 2007
	A	B
1	30x60	16.2
2	25x40	16.2
3	Michigan 20x40 Beige	285.2
4	Michigan 20x40 Beige	44.9
5	Michigan 20x40 Tabaco	405.6
6	Michigan 20x40 Marengo	18.2
7	Michigan 20x40 Beige	65.8
8	25x40	625.2
9
Sheet1

And, after the macro:

Excel 2007
	A	B
1	25x40	641.4
2	30x60	16.2
3	Michigan 20x40 Beige	395.9
4	Michigan 20x40 Marengo	18.2
5	Michigan 20x40 Tabaco	405.6
6
7
8
9
Sheet1

Please TEST this FIRST in a COPY of your workbook (always make a backup copy before trying new code, you never know what you might lose).

1. Copy the below code
2. Open your NEW workbook
3. Press the keys ALT + F11 to open the Visual Basic Editor
4. Press the keys ALT + I to activate the Insert menu
5. Press M to insert a Standard Module
6. Where the cursor is flashing, paste the code
7. Press the keys ALT + Q to exit the Editor, and return to Excel
8. To run the macro from Excel press ALT + F8 to display the Run Macro Dialog. Double Click the macro's name to Run it.

Sub ConsolidateData_Sum()
' hiker95, 12/01/2016, ME865785
Dim lr As Long, r As Long, n As Long
Application.ScreenUpdating = False
With Sheets("Sheet1")   '<-- you can change the sheet name here
  lr = .Cells(Rows.Count, 1).End(xlUp).Row
  .Range("A1:B" & lr).Sort key1:=.Range("A1"), order1:=1
  For r = 1 To lr
    n = Application.CountIf(.Columns(1), .Cells(r, 1).Value)
    If n > 1 Then
      .Range("B" & r).Value = Evaluate("=Sum(B" & r & ":B" & r + n - 1 & ")")
      .Range("A" & r + 1 & ":B" & r + n - 1).ClearContents
    End If
    r = r + n - 1
  Next r
  .Range("A1:B" & lr).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlUp
  .UsedRange.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub

Before you use the macro with Excel 2007 or newer, save your workbook, Save As, a macro enabled workbook with the file extension .xlsm, and, answer the "do you want to enable macros" question as "yes" or "OK" (depending on the button label for your version of Excel) the next time you open your workbook.

Then run the ConsolidateData_Sum macro.