Combining multiple rows into one.

[RodneyC]

• Each week I export a xlsx file from an external source and can't change how the data is exported/received. It usually will have hundreds, maybe even a few thousand rows.
• There are 17 columns, one for each of the 12 months, another 4 representing each of the four quarters and 1 more representing the total for the year.
• Starting with column A, each row is populated with various values, let's say A2 is populated with Channel 4. In this case E2 would be populated with $5000 because $5000 is the value for January.
• Because Channel 4 also had revenue in Feb, A3 is populated with Channel 4 and F3 has a value of $4500 for Feb.
• Channel 4 also had revenue in March so A4 is populated with Channel 4 and G4 has the value of $6000 for March.
• This continues throughout the year, with a new row being added for each month.

I need a formula that will automatically collapse all these rows into one, displaying all data in one row, or maybe another way to do it, I need a formula that will add a new row and total all rows where A has a value of Channel 4. This is easy to do simply by manually adding a new row beneath the last Channel 4 row and summing the columns above. If there were ten or twenty rows, I could do this. With hundreds or thousands of lines, it can't efferently be done manually.

I'm on a new work computer and don't have admin rights to upload the Excel Add In that would enable me to "upload image" so I could share a sample. I'm working on getting that resolved, but thought I'd try with the explanation above.

Thanks in advance

 

[Takae]

A new tab with results will be created. Please try it.

Sub test()
Dim ws1 As Worksheet, Nws As Worksheet
Dim LR As Long, i As Long, j As Long
Dim Dic, buf As String, x, z()

    Set ws1 = Sheets("Sheet1")
    Application.ScreenUpdating = False
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    Set Nws = ActiveSheet
    Set Dic = CreateObject("Scripting.Dictionary")
    With ws1
        LR = .Cells(Rows.Count, 1).End(xlUp).Row
        On Error Resume Next
        For i = 2 To LR
            buf = .Cells(i, 1).Value
            Dic.Add buf, buf
        Next
        
        x = Dic.Keys
        ReDim z(Dic.Count - 1, 12)
        For i = 0 To Dic.Count - 1
            .Range("A1").AutoFilter 1, x(i)
            For j = 5 To 16
                z(i, j - 5) = WorksheetFunction.Subtotal(9, .Range(.Cells(2, j), .Cells(LR, j)))
            Next
        Next
        .Range("A1").AutoFilter
        .Range("E1:Q1").Copy Nws.Range("E1")
    End With
    With Nws
         For i = 0 To Dic.Count - 1
            .Cells(i + 2, 1) = x(i)
        Next
        .Range(.Range("E2"), .Cells(Dic.Count + 1, 16)) = z
        .Range(.Range("Q2"), .Cells(Dic.Count + 1, 17)).Value = "=SUM(E2:P2)"
    End With
    Set Dic = Nothing
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub

 

[RodneyC]

A new tab with results will be created. Please try it.

Sub test()
Dim ws1 As Worksheet, Nws As Worksheet
Dim LR As Long, i As Long, j As Long
Dim Dic, buf As String, x, z()

    Set ws1 = Sheets("Sheet1")
    Application.ScreenUpdating = False
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    Set Nws = ActiveSheet
    Set Dic = CreateObject("Scripting.Dictionary")
    With ws1
        LR = .Cells(Rows.Count, 1).End(xlUp).Row
        On Error Resume Next
        For i = 2 To LR
            buf = .Cells(i, 1).Value
            Dic.Add buf, buf
        Next
       
        x = Dic.Keys
        ReDim z(Dic.Count - 1, 12)
        For i = 0 To Dic.Count - 1
            .Range("A1").AutoFilter 1, x(i)
            For j = 5 To 16
                z(i, j - 5) = WorksheetFunction.Subtotal(9, .Range(.Cells(2, j), .Cells(LR, j)))
            Next
        Next
        .Range("A1").AutoFilter
        .Range("E1:Q1").Copy Nws.Range("E1")
    End With
    With Nws
         For i = 0 To Dic.Count - 1
            .Cells(i + 2, 1) = x(i)
        Next
        .Range(.Range("E2"), .Cells(Dic.Count + 1, 16)) = z
        .Range(.Range("Q2"), .Cells(Dic.Count + 1, 17)).Value = "=SUM(E2:P2)"
    End With
    Set Dic = Nothing
    Application.ScreenUpdating = True
    MsgBox "Done"
End Sub

I will , probably over the weekend. Thank you