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>

 

[ocvmelbye]

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

<colgroup><col style="width: 25pxpx"><col><col></colgroup><thead>
</thead><tbody>
</tbody>

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

<colgroup><col style="width: 25pxpx"><col><col></colgroup><thead>
</thead><tbody>
</tbody>

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.

Before running macro:

	A	B
1	30x60	16.2
2	25x40	0
3	Michigan 20x40 Beige	65
4	Michigan 20x40 Marengo	18
5	Michigan 20x40 Tabaco	405.6
6
7
8
9

<tbody>
</tbody>

Do you know what can be wrong here?

Sub SortTiles()

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]

Do you know what can be wrong here?

ocvmelbye,

I do not understand.

Are my screenshots in my last reply #10 not correct?

 

[hiker95]

ocvmelbye,

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

2. Are you using a PC or a Mac?


If my screenshots in my reply #10 are not correct, then:


I would like to see your actual raw data workbook/worksheet(s), and, what the results should look like.

You can post your workbook/worksheets to the following free site (sensitive data changed), mark the workbook for sharing, and, provide us with a link to your workbook:

https://dropbox.com


If you are not able to provide the above, then:

Click on the Reply to Thread button, and just put the word BUMP in the thread. Then, click on the Post Quick Reply button, and someone else will assist you.