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

Open in new window


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.

Thanks in advance.
LVL 1
gwh2Asked:
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.

Hammadh Abdul RahmanCommented:
Hi gwh2,

Please find the below code.

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

Open in new window

0
gwh2Author 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
gwh2Author Commented:
Also, the SKU is in column A
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

Hammadh Abdul RahmanCommented:
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
Hammadh Abdul RahmanCommented:
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

Open in new window

0
gwh2Author 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
gwh2Author 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
Hammadh Abdul RahmanCommented:
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
gwh2Author 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
gwh2Author 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
Hammadh Abdul RahmanCommented:
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

Open in new window

0
gwh2Author 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

Open in new window

0
gwh2Author Commented:
There seems to be two macros in the spreadsheet?
0
Hammadh Abdul RahmanCommented:
Yes, the old macro which expands, and the new macro which collapses
0
Hammadh Abdul RahmanCommented:
Please check whether the new code I sent fixes the issue.
0
gwh2Author 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

Open in new window

0
Hammadh Abdul RahmanCommented:
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

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

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

Start your 7-day free trial
gwh2Author 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
gwh2Author 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.