asked on

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:

https://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.

Hammadh Abdul Rahman

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

CAE5942

ASKER

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?

CAE5942

ASKER

Also, the SKU is in column A

Hammadh Abdul Rahman

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

Hammadh Abdul Rahman

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

CAE5942

ASKER

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?

CAE5942

ASKER

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

Hammadh Abdul Rahman

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.

CAE5942

ASKER

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?

CAE5942

ASKER

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?

Hammadh Abdul Rahman

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

CAE5942

ASKER

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

CAE5942

ASKER

There seems to be two macros in the spreadsheet?

Hammadh Abdul Rahman

Yes, the old macro which expands, and the new macro which collapses

Hammadh Abdul Rahman

Please check whether the new code I sent fixes the issue.

CAE5942

ASKER

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

ASKER CERTIFIED SOLUTION

Hammadh Abdul Rahman

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial

CAE5942

ASKER

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.

CAE5942

ASKER

Yes thanks so much - that is working perfectly now. I really appreciate your help.