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

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.

Output Data:

...

First I start with 3 helper columns:

A) #s (this could be substituted for just ROW() but I found this easier. 1 to 1000 but feel free to continue at least 5 times larger than your largest expected data set.
B) Counts how may cells are not empty on the RAW sheet to the right of "Posting Status" Column
C) This is a bit less clear. the first cell (C2) must be just the number one, then each following cell, down to row 1000, has this formula:
=IF(COUNTIF($C$1:C2,C2)=INDEX(B:B,MATCH(C2,A:A,0)),C2 1,C2)

Next we start with repeating the General Dataset:
=IF($C2<INDEX($A:$A,MATCH(0,$B:$B,0)),INDEX(RAW!A:A,$C2 1),"")

(this formula is exactly the same through the entire blue section: D2:K1000 )

Now! the really fun part:
In the invoice column:
=IF($C3<INDEX($A:$A,MATCH(0,$B:$B,0)),OFFSET(RAW!$I$1,$C3,((COUNTIF($C$1:$C3,$C3)-1)*4),1,4),"")

Make sure everything is filled all the way down to row 1000 (or whatever your row of choice is) and bob's your Aunty!

To Note:

I'm assuming your column A (count) on the RAW sheet was added by you. If not you will either need to note copy it over, or adjust all the formulas to pull from one cell to the right.
Let me know if you have any troubles with it.

CodePudding user response：

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