Copy every n columns from one row of data and paste to multiple rows

Question

Problem: Our company receives a data set that summarizes invoices to be paid. For each outstanding invoice, there is a single row of data. Each invoice has a variable number of items to be paid and are listed on the same row. Each item has four columns listed on the invoice row. As a result, the number of columns per invoice can become unwieldy.

We need to upload this data with one row per item and it currently requires an accounting clerk to manually copy/paste each item to a new row.

Request: Please help me find a way to copy every item (four columns) and paste to a new row with the invoice listed first.

Attachments: "RAW" Worksheet is the original data.

• Columns A-D, highlighted in Gray are the invoice detail.
• Columns J-M highlighted in Orange are the first item, Columns N-Q highlighted in Blue are the second item, etc. "RAW" Screenshot

"Output" Worksheet is the desired outcome (currently done by manually copy/paste)

"Output" Screenshot

Link to Google Doc for data

Attempts: I am a fairly inexperienced Excel user, but I tried a series of if/then, transpositions, pivots, and Offsets with no success.

I think that this problem requires a VBA that reviews each row and identifies

1. if there is a non-zero four column item. For each non-zero four column item, it will paste the invoice summary (columns A-D) and the non-zero item (ex. columns J-M) on a new row.
2. If there is a zero-value four column item, the VBA will move to the next row (invoice).

That is my best guess, and I haven't a clue how to script this VBA. Thanks for any insight here!!

Answer 1

Transform Data (VBA)

Option Explicit

Sub TransformData()
    
    ' Define constants.
    
    Const SRC_NAME As String = "RAW"
    Const SRC_FIRST_CELL As String = "A3"
    Const SRC_REPEAT_COLUMNS As Long = 9
    Const SRC_CHANGE_COLUMNS As Long = 4
    
    Const DST_NAME As String = "Output"
    Const DST_FIRST_CELL As String = "A2"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the Source range.
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(SRC_NAME)
    Dim sfCell As Range: Set sfCell = sws.Range(SRC_FIRST_CELL)
    
    Dim srg As Range, srOffset As Long, srCount As Long, scCount As Long
    
    With sws.UsedRange
        scCount = .Columns.Count
        srOffset = sfCell.Row - 1
        srCount = .Rows.Count - srOffset
        If srCount < 1 Then
            MsgBox "No data in the Source worksheet.", vbExclamation
            Exit Sub
        End If
        Set srg = .Resize(srCount).Offset(srOffset)
    End With
    
    ' Write the values from the Source range to the Source array.
    
    Dim sData() As Variant: sData = srg.Value
    
    ' Define the Destination array.
    
    Dim scaCount As Long
    scaCount = (scCount - SRC_REPEAT_COLUMNS) / SRC_CHANGE_COLUMNS
    
    Dim drCount As Long: drCount = scaCount * scCount ' could be to many
    Dim dcCount As Long: dcCount = SRC_REPEAT_COLUMNS + SRC_CHANGE_COLUMNS
    
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To dcCount)
    
    ' Transform the data from the Source array
    ' into the Destination array.
    
    Dim sr As Long, sc As Long, scFirst As Long, scLast As Long, sca As Long
    Dim dr As Long, dc As Long
    
    For sr = 1 To srCount
        For sca = 1 To scaCount
            ' Determine the Source Change columns.
            scFirst = 1 + SRC_REPEAT_COLUMNS + (sca - 1) * SRC_CHANGE_COLUMNS
            scLast = scFirst + SRC_CHANGE_COLUMNS - 1
            ' Check if the Source Area is not blank.
            For sc = scFirst To scLast
                If Len(CStr(sData(sr, sc))) > 0 Then Exit For
            Next sc
            ' Write the Source data.
            If sc <= scLast Then ' Source Area is not blank
                dr = dr + 1
                For sc = 1 To SRC_REPEAT_COLUMNS
                    dData(dr, sc) = sData(sr, sc)
                Next sc
                dc = SRC_REPEAT_COLUMNS
                For sc = scFirst To scLast
                    dc = dc + 1
                    dData(dr, dc) = sData(sr, sc)
                Next sc
            'Else ' Source Area is blank; do nothing
            End If
        Next sca
    Next sr
    
    If dr = 0 Then
        MsgBox "No data found.", vbExclamation
        Exit Sub
    End If
    
    Erase sData
    
    ' Reference the Destination range.
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(DST_NAME)
     
    Dim dfCell As Range: Set dfCell = dws.Range(DST_FIRST_CELL)
    Dim drg As Range: Set drg = dfCell.Resize(dr, dcCount)
    
    ' Write the values from the Destination array to the Destination range.
    
    drg.Value = dData
    drg.Resize(dws.Rows.Count - drg.Row - dr + 1).Offset(dr).Clear
    
    ' Inform.
    
    MsgBox "Data transformed.", vbInformation
    
End Sub