Consolidating information from columns into rows

[johnnyknight]

Hey! I'm new here. Just started learning macros and it's been a godsend. I have a report that has been a bit overwhelming to try to tackle on my own, and I'd be grateful for any advice and/or help.

So I get these reports with customers' information (name, address, etc) and what they purchased from a site. The items are separated out into columns, though. The item name is the header and the cell has the size. Next to that is the purchase price.

I need to consolidate the product information (product name&product size) into a column with additional items added into new rows like this...

 

[shknbk2]

Welcome to the forum. Good luck in your efforts to learn VBA.

Here's a sample code that duplicates your information. Based on your images, I am assuming the data sets are on separate pages. The code below would be run after making sure the source data sheet was active. The code assumes that the target sheet is called "Sheet2", but you can change that to the actual name in your workbook if it is different.

Let me know if there is anything you don't understand in the code or if you need further adjustments that you can't quite get, yet.

Sub ConsolodateProducts()
    Dim Products As Variant
    Dim NameList() As String
    Dim ListCount As Integer
    Dim i As Integer, j As Integer
    
    Products = Range("A1").CurrentRegion.Value
    ListCount = 1
    ReDim Preserve NameList(1 To 4, 1 To 1)
    NameList(1, 1) = Products(1, 1)
    NameList(2, 1) = Products(1, 2)
    NameList(3, 1) = "Item"
    NameList(4, 1) = "Price"
    For i = 2 To UBound(Products)
        For j = 3 To UBound(Products, 2) - 1 Step 2
            If Products(i, j) <> "" Then
                ListCount = ListCount + 1
                ReDim Preserve NameList(1 To 4, 1 To ListCount)
                NameList(1, ListCount) = Products(i, 1)
                NameList(2, ListCount) = Products(i, 2)
                NameList(3, ListCount) = Products(1, j) & " " & Products(i, j)
                If InStr(1, NameList(3, ListCount), "(") > 0 Then
                    NameList(3, ListCount) = Trim(Left(NameList(3, ListCount), InStr(1, NameList(3, ListCount), "(") - 1))
                End If
                NameList(4, ListCount) = Products(i, j + 1)
            End If
        Next j
    Next i
    If ListCount > 1 Then
        With Worksheets("Sheet2").Range("A1")
            .CurrentRegion.ClearContents
            .Resize(ListCount, 4).Value = Application.WorksheetFunction.Transpose(NameList)
        End With
    End If
End Sub

 

[johnnyknight]

Thank you very much! What's the best way to adjust the code if the sheet has more columns of the customers' information? In the example above, the first and last name is only columns A & B. What if their information takes up columns A through K?

 

[shknbk2]

Without seeing the data, I'd say to change the 3 in this line (which identifies that col C is the column where the product information starts per your first example) to 12 assuming that the product information starts in col L. If it starts in another column, just put that column number in.

For j = 12 To UBound(Products, 2) - 1 Step 2

 

[johnnyknight]

Oh it's so close.

Here's a better look at all of the information that we get

 

[shknbk2]

So let's have the data refer to the columns with the names rather than the dates and times:

Products(1, 1) or Products(i, 1) go to Products(1, 6) and Products(i, 6)
Products(1, 2) or Products(i, 2) go to Products(1, 5) and Products(i, 5)

Sub ConsolodateProducts()
    Dim Products As Variant
    Dim NameList() As String
    Dim ListCount As Integer
    Dim i As Integer, j As Integer
    
    Products = Range("A1").CurrentRegion.Value
    ListCount = 1
    ReDim Preserve NameList(1 To 4, 1 To 1)
    NameList(1, 1) = Products(1, 6)
    NameList(2, 1) = Products(1, 5)
    NameList(3, 1) = "Item"
    NameList(4, 1) = "Price"
    For i = 2 To UBound(Products)
        For j = 12 To UBound(Products, 2) - 1 Step 2
            If Products(i, j) <> "" Then
                ListCount = ListCount + 1
                ReDim Preserve NameList(1 To 4, 1 To ListCount)
                NameList(1, ListCount) = Products(i, 6)
                NameList(2, ListCount) = Products(i, 5)
                NameList(3, ListCount) = Products(1, j) & " " & Products(i, j)
                If InStr(1, NameList(3, ListCount), "(") > 0 Then
                    NameList(3, ListCount) = Trim(Left(NameList(3, ListCount), InStr(1, NameList(3, ListCount), "(") - 1))
                End If
                NameList(4, ListCount) = Products(i, j + 1)
            End If
        Next j
    Next i
    If ListCount > 1 Then
        With Worksheets("Sheet2").Range("A1")
            .CurrentRegion.ClearContents
            .Resize(ListCount, 4).Value = Application.WorksheetFunction.Transpose(NameList)
        End With
    End If
End Sub

 

[johnnyknight]

Sorry I meant that I wanted to preserve all of the customers' information in columns A thru K. I think I got it by amending your code to the following:

Sub ConsolodateProducts()
Dim Products As Variant
Dim NameList() As String
Dim ListCount As Integer
Dim i As Integer, j As Integer

Products = Range("A1").CurrentRegion.Value
ListCount = 1
ReDim Preserve NameList(1 To 13, 1 To 1)
NameList(1, 1) = Products(1, 1)
NameList(2, 1) = Products(1, 2)
NameList(3, 1) = Products(1, 3)
NameList(4, 1) = Products(1, 4)
NameList(5, 1) = Products(1, 5)
NameList(6, 1) = Products(1, 6)
NameList(7, 1) = Products(1, 7)
NameList(8, 1) = Products(1, 8)
NameList(9, 1) = Products(1, 9)
NameList(10, 1) = Products(1, 10)
NameList(11, 1) = Products(1, 11)
NameList(12, 1) = "Item"
NameList(13, 1) = "Price"
For i = 2 To UBound(Products)
For j = 12 To UBound(Products, 2) - 1 Step 2
If Products(i, j) <> "" Then
ListCount = ListCount + 1
ReDim Preserve NameList(1 To 13, 1 To ListCount)
NameList(1, ListCount) = Products(i, 1)
NameList(2, ListCount) = Products(i, 2)
NameList(3, ListCount) = Products(i, 3)
NameList(4, ListCount) = Products(i, 4)
NameList(5, ListCount) = Products(i, 5)
NameList(6, ListCount) = Products(i, 6)
NameList(7, ListCount) = Products(i, 7)
NameList(8, ListCount) = Products(i, 8)
NameList(9, ListCount) = Products(i, 9)
NameList(10, ListCount) = Products(i, 10)
NameList(11, ListCount) = Products(i, 11)
NameList(12, ListCount) = Products(1, j) & " " & Products(i, j)
If InStr(1, NameList(12, ListCount), "(") > 0 Then
NameList(12, ListCount) = Trim(Left(NameList(12, ListCount), InStr(1, NameList(12, ListCount), "(") - 1))
End If
NameList(13, ListCount) = Products(i, j + 1)
End If
Next j
Next i
If ListCount > 1 Then
With Worksheets("Sheet2").Range("A1")
.CurrentRegion.ClearContents
.Resize(ListCount, 13).Value = Application.WorksheetFunction.Transpose(NameList)
End With
End If
End Sub

 

[shknbk2]

It looks like you got it.
To shorten it up a bit, you could use a For loop for the repetitive assignments:

Sub ConsolodateProducts()
    Dim Products As Variant
    Dim NameList() As String
    Dim ListCount As Integer
    Dim i As Integer, j As Integer, k As Integer
    
    Products = Range("A1").CurrentRegion.Value
    ListCount = 1
    ReDim Preserve NameList(1 To 13, 1 To 1)
    For k = 1 To 11
        NameList(k, 1) = Products(1, k)
    Next
    NameList(12, 1) = "Item"
    NameList(13, 1) = "Price"
    For i = 2 To UBound(Products)
        For j = 12 To UBound(Products, 2) - 1 Step 2
            If Products(i, j) <> "" Then
                ListCount = ListCount + 1
                ReDim Preserve NameList(1 To 13, 1 To ListCount)
                For k = 1 To 11
                    NameList(k, ListCount) = Products(i, k)
                Next
                NameList(12, ListCount) = Products(1, j) & " " & Products(i, j)
                If InStr(1, NameList(12, ListCount), "(") > 0 Then
                    NameList(12, ListCount) = Trim(Left(NameList(12, ListCount), InStr(1, NameList(12, ListCount), "(") - 1))
                End If
                NameList(13, ListCount) = Products(i, j + 1)
            End If
        Next j
    Next i
    If ListCount > 1 Then
        With Worksheets("Sheet2").Range("A1")
            .CurrentRegion.ClearContents
            .Resize(ListCount, 13).Value = Application.WorksheetFunction.Transpose(NameList)
        End With
    End If
End Sub

 

[johnnyknight]

Ahhh I see. Thank you so much for the help!