# 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?
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
``````
0
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?
0
Author Commented:
Also, the SKU is in column A
0
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
0
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
``````
0
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?
0
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
0
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.
0
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?
0
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?
0
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
``````
0
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
``````
0
Author Commented:
There seems to be two macros in the spreadsheet?
0
Commented:
Yes, the old macro which expands, and the new macro which collapses
0
Commented:
Please check whether the new code I sent fixes the issue.
0
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
``````
0
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
``````
0

Experts Exchange Solution brought to you by

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Author Commented:
Sorry please disregard that comment about the old and new code blocks. As mentioned in the previous post, I tried the new code block but I'm still getting the same error.
0
Author Commented:
Yes thanks so much - that is working perfectly now. I really appreciate your help.
0
###### It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.

Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.