Consolidate information in multiple columns into one column with unique values

S

Steve_nyc92

New Member
Joined
Dec 17, 2020
Messages
23
Office Version
  1. 2016
Platform
  1. Windows
Hi

I am trying to consolidate multiple columns of information into one single column. The current table has duplicative information so when it goes to one column, all data should be a unique value. Below is an example of what it is. The first column is the highest level, and then each column after is a child of the column to the left of it. So within Residential, you can be Large, Medium or Small. Within Large, you can have different capacity, etc.

TypeSizeCapacityMaterialFloors
ResidentialLarge1000 - 2000Brick20
ResidentialLarge> 1000Wood20
ResidentialLarge800 - 1000Wood15
ResidentialMedium500-800Wood10
ResidentialSmall< 100Vinyl5
BusinessExtremely Large> 10,000Steel100
BusinessExtremely Large> 10,000Steel100
BusinessAverage5,000 - 10,000Concrete50
BusinessAverage5,000 - 10,000Concrete50
BusinessSmall< 5,000Concrete/Steel30

and ultimately I'm trying to make it look like this

TypeResidential
SizeLarge
Capacity1000 - 2000
MaterialBrick
Floors20
MaterialWood
Floors20
Capacity> 1000
MaterialWood
Floors20
SizeMedium
Capacity500-800
MaterialWood
Floors10

I don't think there is any easy way to concatenate as the number of duplicative columns can vary with each subset
 

Excel Facts

How to total the visible cells?
From the first blank cell below a filtered data set, press Alt+=. Instead of SUM, you will get SUBTOTAL(9,)
Sort by date Sort by votes
I'm sure there's a more elegant solution than this, but if you were after VBA, then this should do until something better comes along. It assumes your top table is on sheet1 of the workbook you place this code in, and that sheet2 is available to put your second table into. Also assumes that your top table starts in cell A1 in sheet1. Let me know how you go.

VBA Code: 
Option Explicit
Sub ResBus()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim lrow As Long, i As Long, j As Long
    Dim titles, data, c As Range
    Application.ScreenUpdating = False
    Set ws1 = ThisWorkbook.Sheets(1)
    Set ws2 = ThisWorkbook.Sheets(2)
    
    ws2.Cells.ClearContents
    ws1.Cells(1, 1).CurrentRegion.Copy ws2.Cells(1, 3)
    ws2.Cells(1, 3).CurrentRegion.RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5), Header:=xlYes
    ws2.Columns("C:G").Sort Key1:=ws2.Range("C1"), order1:=xlDescending, Header:=xlYes
    
    lrow = ws2.Cells(Rows.Count, 3).End(xlUp).Row
    titles = ws2.Range(ws2.Cells(1, 3), ws2.Cells(1, 7))
    
    j = 1
    For i = 1 To lrow - 1
        ws2.Cells(j, 1).Resize(5, 1).Value = Application.Transpose(titles)
        j = (i * 5) + 1
    Next i
    
    j = 1
    For i = 2 To lrow
        data = ws2.Range(ws2.Cells(i, 3), ws2.Cells(i, 7))
        ws2.Cells(j, 2).Resize(5, 1).Value = Application.Transpose(data)
        j = j + 5
    Next i
    
    ws2.Range(ws2.Cells(1, 3), ws2.Cells(1, 7)).EntireColumn.ClearContents
    ws2.Range("A:B").ColumnWidth = 20
    ws2.Range("A:B").HorizontalAlignment = xlLeft
    
    i = 0
    j = 0
    lrow = ws2.Cells(Rows.Count, 1).End(xlUp).Row
    For Each c In ws2.Range(ws2.Cells(1, 2), ws2.Cells(lrow, 2))
        If c = "Residential" Then i = i + 1
        If c = "Business" Then j = j + 1
        If i > 1 Then
            c.EntireRow.Delete
            i = 1
        End If
        If j > 1 Then
            c.EntireRow.Delete
            j = 1
        End If
    Next c
End Sub
 
Upvote 0
Here's another way, probably closer to what you want. Everything takes place on sheet1 of the workbook with the code.

VBA Code: 
Option Explicit
Sub ParentChild()
    Dim LastRow As Long, i As Long, rng As Range, c As Range
    Application.ScreenUpdating = False
    
    LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    
    'Create a copy of the data to keep to the original format
    Sheet1.Range("A1:E" & LastRow).Copy Sheet1.Range("K1")
    Sheet1.Range("C2:C" & LastRow).Replace what:=",", replacement:=vbNullString
    
    With Sheet1.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Sheet1.Range("A1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("B1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("C1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("D1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("E1"), Order:=xlDescending
        .SetRange Sheet1.Range("A1:E" & LastRow)
        .Header = xlYes
        .Apply
    End With
    
    'Concatenate with delimiter, sort & replace cols A:E values
    With Sheet1.Range("G2:G" & LastRow)
        .FormulaR1C1 = "=RC1&"",""&RC2&"",""&RC3&"",""&RC4&"",""&RC5"
        .Value = .Value
        .Sort Key1:=Sheet1.Range("G2"), order1:=xlDescending
        Application.DisplayAlerts = False
        .TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1))
        Application.DisplayAlerts = True
        .Clear
    End With
    
    'Delete sequential 'parents'
    Set rng = Sheet1.Range("A2:E" & LastRow)
    For i = rng.Cells.Count To 1 Step -1
        If rng.Item(i) = rng.Item(i).Offset(-1) Then
            rng.Item(i).ClearContents
        End If
    Next i
    
    'Copy to new column
    i = 1
    For Each c In Sheet1.Range("A2:E" & LastRow)
        If c.Value = "" Then GoTo Skip
            c.Copy Sheet1.Cells(i, 8)
            Cells(1, c.Column).Copy Sheet1.Cells(i, 7)
        i = i + 1
Skip:
    Next c
    
    With Sheet1.Range("G:H")
        .ColumnWidth = 25
        .HorizontalAlignment = xlLeft
    End With
    
    'Restore original order & clear copy
    Sheet1.Range("K1:O" & LastRow).Copy Sheet1.Range("A1")
    Sheet1.Range("K:O").ClearContents
End Sub
 
Last edited:
Upvote 0
kevin9999 said:
Here's another way, probably closer to what you want. Everything takes place on sheet1 of the workbook with the code.

VBA Code: 
Option Explicit
Sub ParentChild()
    Dim LastRow As Long, i As Long, rng As Range, c As Range
    Application.ScreenUpdating = False
   
    LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
   
    'Create a copy of the data to keep to the original format
    Sheet1.Range("A1:E" & LastRow).Copy Sheet1.Range("K1")
    Sheet1.Range("C2:C" & LastRow).Replace what:=",", replacement:=vbNullString
   
    With Sheet1.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Sheet1.Range("A1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("B1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("C1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("D1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("E1"), Order:=xlDescending
        .SetRange Sheet1.Range("A1:E" & LastRow)
        .Header = xlYes
        .Apply
    End With
   
    'Concatenate with delimiter, sort & replace cols A:E values
    With Sheet1.Range("G2:G" & LastRow)
        .FormulaR1C1 = "=RC1&"",""&RC2&"",""&RC3&"",""&RC4&"",""&RC5"
        .Value = .Value
        .Sort Key1:=Sheet1.Range("G2"), order1:=xlDescending
        Application.DisplayAlerts = False
        .TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1))
        Application.DisplayAlerts = True
        .Clear
    End With
   
    'Delete sequential 'parents'
    Set rng = Sheet1.Range("A2:E" & LastRow)
    For i = rng.Cells.Count To 1 Step -1
        If rng.Item(i) = rng.Item(i).Offset(-1) Then
            rng.Item(i).ClearContents
        End If
    Next i
   
    'Copy to new column
    i = 1
    For Each c In Sheet1.Range("A2:E" & LastRow)
        If c.Value = "" Then GoTo Skip
            c.Copy Sheet1.Cells(i, 8)
            Cells(1, c.Column).Copy Sheet1.Cells(i, 7)
        i = i + 1
Skip:
    Next c
   
    With Sheet1.Range("G:H")
        .ColumnWidth = 25
        .HorizontalAlignment = xlLeft
    End With
   
    'Restore original order & clear copy
    Sheet1.Range("K1:O" & LastRow).Copy Sheet1.Range("A1")
    Sheet1.Range("K:O").ClearContents
End Sub
Click to expand...
Wow this work great! Thank you! I actually realized I have 7 columns of data (A1 through G1). I updated your code to reflect this but for some reason get a compiling error at this part. What am I doing wrong?

With Sheet1.Range("I2:I" & LastRow)
.FormulaR1C1 = "=RC1&"",""&RC2&"",""&RC3&"",""&RC4&"",""&RC5",""&RC6",""&RC7"
 
Upvote 0
Thank you for the feedback Steve.

The code would need to be amended in several places. I don't know what your data looks like in columns F:G but the following amended code should work for you:

VBA Code: 
Option Explicit
Sub ParentChild()
    Dim LastRow As Long, i As Long, rng As Range, c As Range
    Application.ScreenUpdating = False
    
    LastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    
    'Create a copy of the data to keep to the original format
    Sheet1.Range("A1:G" & LastRow).Copy Sheet1.Range("L1")
    Sheet1.Range("C2:G" & LastRow).Replace what:=",", replacement:=vbNullString
    
    With Sheet1.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Sheet1.Range("A1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("B1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("C1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("D1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("E1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("E1"), Order:=xlDescending
        .SortFields.Add Key:=Sheet1.Range("E1"), Order:=xlDescending
        .SetRange Sheet1.Range("A1:G" & LastRow)
        .Header = xlYes
        .Apply
    End With
    
    'Concatenate with delimiter, sort & replace cols A:G values
    With Sheet1.Range("H2:H" & LastRow)
        .FormulaR1C1 = "=RC1&"",""&RC2&"",""&RC3&"",""&RC4&"",""&RC5&"",""&RC6&"",""&RC7"
        .Value = .Value
        .Sort Key1:=Sheet1.Range("H2"), order1:=xlDescending
        Application.DisplayAlerts = False
        .TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1))
        Application.DisplayAlerts = True
        .Clear
    End With
    
    'Delete sequential 'parents'
    Set rng = Sheet1.Range("A2:G" & LastRow)
    For i = rng.Cells.Count To 1 Step -1
        If rng.Item(i) = rng.Item(i).Offset(-1) Then
            rng.Item(i).ClearContents
        End If
    Next i
    
    'Copy to new column
    i = 1
    For Each c In Sheet1.Range("A2:G" & LastRow)
        If c.Value = "" Then GoTo Skip
            c.Copy Sheet1.Cells(i, 10)
            Cells(1, c.Column).Copy Sheet1.Cells(i, 9)
        i = i + 1
Skip:
    Next c
    
    With Sheet1.Range("I:J")
        .ColumnWidth = 25
        .HorizontalAlignment = xlLeft
    End With
    
    'Restore original order & clear copy
    Sheet1.Range("L1:R" & LastRow).Copy Sheet1.Range("A1")
    Sheet1.Range("L:R").ClearContents

End Sub
 
Upvote 0
Solution
Thanks. I am getting a runtime error '13' Type mismatch in the code where it offset (-1)

'Delete sequential 'parents'
Set rng = Sheet1.Range("A2:G" & LastRow)
For i = rng.Cells.Count To 1 Step -1
If rng.Item(i) = rng.Item(i).Offset(-1) Then
rng.Item(i).ClearContents
End If
Next i
 
Upvote 0
Unfortunately Steve, I can't replicate the error you're getting - it's working fine on the data I'm using. To progress this any further, you'll need to upload a sample of your actual data using the XL2BB Tool otherwise I'm at a loss to help you further.
 
Upvote 0
Thanks... I tried it again. I had an extra worksheet in the book and so I deleted it. I also had saved the file as an .xlsb so I think that caused it issues.

It works fine now.

Thanks so much, you've saved me a lot of manual copying and pasting!
 
Upvote 0
You must log in or register to reply here.

Similar threads

J
  • Question Question
Power Query editor OR VBA to extract data from Grants.gov
Replies
3
Views
389
Jagadeshrao
J
G
  • Question Question
Help me with this!
Replies
1
Views
357
bobaol
B
S
  • Question Question
Code to use multiple trigger cells to hide / unhide rows of corresponding question sets
Replies
1
Views
1K
dmt32
D
N
  • Question Question
Data consolidation between multiple sheets into one
Replies
1
Views
716
severynm
severynm
X
  • Question Question
Trying to INDIRECT XLOOKUP in closed workbooks. Looking for a VBA solution
Replies
3
Views
835
Fluff
Fluff

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top