# Macro to collapse data across multiple rows

Hi everyone,

A while ago I posted a question about a macro that expands data across multiple rows. The post can be found at the following url:

http://www.experts-exchange.com/questions/28695911/Macro-to-expand-data-across-multiple-rows.html

I attached an excel file with sample data in the above mentioned post. Sheet 1 contains 2 rows (excluding the header row). The first row contains 3 colours in Column B and the second row contains 6 colours in Column B. If you look at Sheet 2, you can see that there are now 9 rows, ie. 3 for the first SKU (in sheet 1) and 6 for the second SKU (in sheet 1) and each of the colours from column B is now separated out onto its own row.

In order to process sheet 1 so that it looks like sheet 2, I was given the following macro which works great:

``````Sub macro()
For Idx = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
Set c = Cells(Idx, 7)
If InStr(1, c, "|") > 0 Then
Colors = Split(c, "|")
NrColors = UBound(Colors)
c.EntireRow.Copy
Rows(c.Row + 1 & ":" & c.Row + NrColors).Insert Shift:=xlDown
For Idx1 = 0 To NrColors
c.Offset(Idx1) = Colors(Idx1)
Next
End If
Next
End Sub
``````

However I now need the opposite to happen, ie. the data in sheet 2 is the original data and I need it to be collapsed into the data of sheet 1.

I wondered if it was possible to revise the above macro so that it does the opposite as described above?

I’d really be grateful for any advice.

LVL 1
###### Who is Participating?

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Commented:
Hi gwh2,

``````Sub CollapseRows()

For Idx = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
' Loop from bottom row to first row
Set c = Cells(Idx, 1)

If Idx = Range("A" & Rows.Count).End(xlUp).Row Then
' If the Initial row (bottom), initialize variables
lowerRow = Idx
SKU = c
Colors = Cells(Idx, 2)
ElseIf SKU <> c Then
' If the same SKU is different, delete excess rows and update color cell
upperRow = Idx

If (upperRow <> lowerRow) Then
Range(Cells(upperRow + 1, 1), Cells(lowerRow - 1, 1)).EntireRow.Delete
Cells(upperRow + 1, 2) = Colors
End If

Colors = Cells(Idx, 2)
lowerRow = Idx
SKU = c
Else
' If the SKU is same as the previous row, append color
Colors = Cells(Idx, 2) & "|" & Colors
End If
Next
End Sub
``````
Author Commented:
Thanks for the reply and the code. I tried running the macro but I got an error saying "Object required". The columns go from A to AJ and the colours are in column G so I'm not sure if this makes a difference to the code. Can you advise further?
Author Commented:
Also, the SKU is in column A
Commented:
I used the Excel sheet from your previous post. Maybe there is some difference in the column positions. Please find attached the sheet in which I tested. test-data2.xlsm
Commented:
The column numbers are now updated as you mentioned

``````Sub CollapseRows()

For Idx = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
' Loop from bottom row to first row
Set c = Cells(Idx, 1)

If Idx = Range("A" & Rows.Count).End(xlUp).Row Then
' If the Initial row (bottom), initialize variables
lowerRow = Idx
SKU = c
Colors = Cells(Idx, 7)
ElseIf SKU <> c Then
' If the same SKU is different, delete excess rows and update color cell
upperRow = Idx

If (upperRow <> lowerRow) Then
Range(Cells(upperRow + 1, 1), Cells(lowerRow - 1, 1)).EntireRow.Delete
Cells(upperRow + 1, 7) = Colors
End If

Colors = Cells(Idx, 7)
lowerRow = Idx
SKU = c
Else
' If the SKU is same as the previous row, append color
Colors = Cells(Idx, 7) & "|" & Colors
End If
Next
End Sub
``````
Author Commented:
Thanks again for the code but it still says "Object is required" when I try to run the code. Do you know what this error means?
Author Commented:
My current spreadsheet contains the following column headers going from A to AJ:

sku
type
image
images
image_labels
swatch_path
colour
colour_groups
size
status
supplier_name
gender
categories
name
relation
description
composition
meta_title
meta_description
meta_keyword
short_description
associated_products
style_code
price
is_in_stock
qty
visibility
websites
small_image
thumbnail
tax_class_id
configurable_attributes
spec_chart
colour_clone
alt_code
category_ids
Commented:
The error means that an object in invalid or an invalid operation is performed on a object.

Help me isolate the issue. Check whether expand and collapse works in the Excel sheet I sent.
Author Commented:
The excel sheet that you provided doesn't contain any data in sheet 2 other than the column headers so how can I test it?
Author Commented:
I pasted in data from the spreadsheet from my last post. I then tested the code and yes it works but it doesn't work on my current spreadsheet with the extended columns. Can you help further?
Commented:
There was a bug, which cause error if there is only one color from a SKU. It is now fixed.

``````Sub CollapseRows()

For Idx = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
' Loop from bottom row to first row
Set c = Cells(Idx, 1)

If Idx = Range("A" & Rows.Count).End(xlUp).Row Then
' If the Initial row (bottom), initialize variables
lowerRow = Idx
SKU = c
Colors = Cells(Idx, 7)
ElseIf SKU <> c Then
' If the same SKU is different, delete excess rows and update color cell
upperRow = Idx

If (upperRow + 1 <> lowerRow) Then
Range(Cells(upperRow + 1, 1), Cells(lowerRow - 1, 1)).EntireRow.Delete
Cells(upperRow + 1, 7) = Colors
End If

Colors = Cells(Idx, 7)
lowerRow = Idx
SKU = c
Else
' If the SKU is same as the previous row, append color
Colors = Cells(Idx, 7) & "|" & Colors
End If
Next
End Sub
``````
Author Commented:
I also noticed that the macro in the spreadsheet you provided is different to the original one you supplied, ie. it's longer. The following is what was in the spreadsheet:

``````Sub Macro1()
'
' Macro1 Macro
'

'
For Idx = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
Set c = Cells(Idx, 2)
If InStr(1, c, "|") > 0 Then
Colors = Split(c, "|")
NrColors = UBound(Colors)
c.EntireRow.Copy
Rows(c.Row + 1 & ":" & c.Row + NrColors).Insert Shift:=xlDown
For Idx1 = 0 To NrColors
c.Offset(Idx1) = Colors(Idx1)
Next
End If
Next
End Sub
Sub CollapseRows()

For Idx = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
' Loop from bottom row to first row
Set c = Cells(Idx, 1)

If Idx = Range("A" & Rows.Count).End(xlUp).Row Then
' If the Initial row (bottom), initialize variables
lowerRow = Idx
SKU = c
Colors = Cells(Idx, 2)
ElseIf SKU <> c Then
' If the same SKU is different, delete excess rows and update color cell
upperRow = Idx

If (upperRow <> lowerRow) Then
Range(Cells(upperRow + 1, 1), Cells(lowerRow - 1, 1)).EntireRow.Delete
Cells(upperRow + 1, 2) = Colors
End If

Colors = Cells(Idx, 2)
lowerRow = Idx
SKU = c
Else
' If the SKU is same as the previous row, append color
Colors = Cells(Idx, 2) & "|" & Colors
End If
Next
End Sub
``````
Author Commented:
There seems to be two macros in the spreadsheet?
Commented:
Yes, the old macro which expands, and the new macro which collapses
Commented:
Please check whether the new code I sent fixes the issue.
Author Commented:
Hi, firstly I ran the code as you provided it, ie. I chose the macro called Sub CollapseRows() but again it produced the same error, ie. "Object required". I then revised your code so that it's targeting column G (see code below). I ran that code but again I get the same error.

Am I supposed to run the Sub Macro1() before Sub CollapseRows() - ie. could this be the problem?

``````Sub Macro1()
'
' Macro1 Macro
'

'
For Idx = Range("A" & Rows.Count).End(xlUp).Row To 2 Step -1
Set c = Cells(Idx, 7)
If InStr(1, c, "|") > 0 Then
Colors = Split(c, "|")
NrColors = UBound(Colors)
c.EntireRow.Copy
Rows(c.Row + 1 & ":" & c.Row + NrColors).Insert Shift:=xlDown
For Idx1 = 0 To NrColors
c.Offset(Idx1) = Colors(Idx1)
Next
End If
Next
End Sub
Sub CollapseRows()

For Idx = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
' Loop from bottom row to first row
Set c = Cells(Idx, 1)

If Idx = Range("A" & Rows.Count).End(xlUp).Row Then
' If the Initial row (bottom), initialize variables
lowerRow = Idx
SKU = c
Colors = Cells(Idx, 7)
ElseIf SKU <> c Then
' If the same SKU is different, delete excess rows and update color cell
upperRow = Idx

If (upperRow <> lowerRow) Then
Range(Cells(upperRow + 1, 1), Cells(lowerRow - 1, 1)).EntireRow.Delete
Cells(upperRow + 1, 7) = Colors
End If

Colors = Cells(Idx, 7)
lowerRow = Idx
SKU = c
Else
' If the SKU is same as the previous row, append color
Colors = Cells(Idx, 7) & "|" & Colors
End If
Next
End Sub
``````
Commented:
Please check whether the below code fixes the issue. (I am reposting this because I think you missed the comment)

``````Sub CollapseRows()

For Idx = Range("A" & Rows.Count).End(xlUp).Row To 1 Step -1
' Loop from bottom row to first row
Set c = Cells(Idx, 1)

If Idx = Range("A" & Rows.Count).End(xlUp).Row Then
' If the Initial row (bottom), initialize variables
lowerRow = Idx
SKU = c
Colors = Cells(Idx, 7)
ElseIf SKU <> c Then
' If the same SKU is different, delete excess rows and update color cell
upperRow = Idx

If (upperRow + 1 <> lowerRow) Then
Range(Cells(upperRow + 1, 1), Cells(lowerRow - 1, 1)).EntireRow.Delete
Cells(upperRow + 1, 7) = Colors
End If

Colors = Cells(Idx, 7)
lowerRow = Idx
SKU = c
Else
' If the SKU is same as the previous row, append color
Colors = Cells(Idx, 7) & "|" & Colors
End If
Next
End Sub
``````

Experts Exchange Solution brought to you by