How do can I turn some rows of input into multiple new rows depending row contents with VBA/macros?

Question

I have an Excel sheet with 4 pages that takes input budgetary adjustment data and reformats into two different formats for entry into different budget softwares.

On the sheets first page, the upload page (feed data), data is given in rows of budget adjustments. These adjustments always come in even numbers of rows because for every account that has money adjusted out of it, another account has that money adjusted into it. In each row there are a number of non-unique qualitative columns that describe the adjustment and then 12 month columns that record the monetary aspects of the adjustment. Some rows have only one month of the 12 filled and can be left alone. Other adjustments occur over several months and thus have several of the months columns filled.

For input into the two budget softwares, these rows that have multiple month columns filled with data need to be expanded into multiple new rows with only one of the 12 columns filled. For clarity, here's what the transformation should look like:

Input:

Output:

How can you do this with input data where some rows don't need to be transformed, some include 2 months of transactions, and some could include up to 12?

user_6299848 · Answer

Option Explicit

Sub Only_one_data_value_per_row()

    Dim myR As Range
    Dim rowCt As Integer
    Dim actRange As Range
    Dim dataCt As Integer
    Dim iCt As Integer
    Dim myCell As Range
    
    Set actRange = Range("A1").CurrentRegion
    
    For rowCt = actRange.Rows.Count To 2 Step -1
    
        With ActiveSheet.Rows(rowCt)
            dataCt = Application.WorksheetFunction.Count(.Range("E1:P1"))
            'Debug.Print .Range("E1:P1").Address, dataCt)
            
            For iCt = 1 To dataCt - 1
                Rows(rowCt + 1).EntireRow.Insert
                Rows(rowCt).Range("A1:D1").Copy Rows(rowCt + 1).Range("A1")
            Next iCt
            
            iCt = 0
            For Each myCell In Rows(rowCt).Range("E1:P1")
                'Debug.Print rowCt; ":"; (nonEmptyCell)
                If myCell.Value <> "" Then
                    Debug.Print myCell.Value
                    If Val(myCell.Value) = 0 Then
                        MsgBox "The value of the cell " & myCell.Address & _
                               " is 0! The cell will be deleted!"
                        myCell.Value = ""
                    Else
                        If iCt > 0 Then
                            myCell.Offset(iCt, 0).Value = myCell.Value
                            myCell.Value = ""
                        End If
                        iCt = iCt + 1
                    End If
                End If
            Next myCell
        End With
    Next rowCt
End Sub

Input:

Output:

user_9814069 · Answer

Transform Data: One Value Per Row

Adjust the values in the constants section.

Option Explicit

Sub TransformOneValuePerRow()
    
    ' Source
    Const sName As String = "Sheet1"
    Const sFirstCellAddress As String = "C4"
    ' Destination
    Const dName As String = "Sheet2"
    Const dFirstCellAddress As String = "A1"
    ' Both
    Const FixedColumnsCount As Long = 4
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the current region starting with the first cell.
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim sFirstCell As Range: Set sFirstCell = sws.Range(sFirstCellAddress)
    Dim srg As Range
    With sFirstCell.CurrentRegion
        Set srg = sFirstCell.Resize(.Row + .Rows.Count - sFirstCell.Row, _
            .Column + .Columns.Count - sFirstCell.Column)
    End With
    
    ' Using 'GetTransformOneValuePerRow', return the transformed data
    ' in a 2D one-based array.
    Dim Data As Variant
    Data = GetTransformOneValuePerRow(srg, FixedColumnsCount)
    If IsEmpty(Data) Then
        MsgBox "An error occurred.", vbCritical
        Exit Sub
    End If
    
    ' Write to the destination range and clear below.
    Dim rCount As Long: rCount = UBound(Data, 1)
    With wb.Worksheets(dName).Range(dFirstCellAddress).Resize(, UBound(Data, 2))
        .Resize(rCount).Value = Data
        .Resize(.Worksheet.Rows.Count - .Row - rCount + 1).Offset(rCount).Clear
    End With
    
    MsgBox "Data transformed.", vbInformation
    
End Sub


Function GetTransformOneValuePerRow( _
    ByVal SourceRange As Range, _
    Optional ByVal FixedColumnsCount As Long = 1, _
    Optional ByVal IncludeBlanks As Boolean = False) _
As Variant
    Const ProcName As String = "GetTransformOneValuePerRow"
    On Error GoTo ClearError

    Dim sData As Variant ' Source Array
    Dim srCount As Long ' Source Rows Count
    Dim cCount As Long ' Source/Destination Columns Count
    Dim drCount As Long ' Destination Rows Count
    
    With SourceRange
        srCount = .Rows.Count
        cCount = .Columns.Count
        With .Resize(srCount - 1, cCount - FixedColumnsCount) _
                .Offset(1, FixedColumnsCount - 1) ' Values Range
            drCount = .Rows.Count * .Columns.Count + 1
            If Not IncludeBlanks Then _
                    drCount = drCount - Application.CountBlank(.Cells)
        End With
        sData = .Value
    End With
    
    Dim dData As Variant: ReDim dData(1 To drCount, 1 To cCount) ' Dest. Array
    Dim fvCol As Long: fvCol = FixedColumnsCount + 1 ' First Value Column
    Dim dr As Long: dr = 1 ' Destination Row
    
    Dim sr As Long ' Source Row
    Dim fc As Long ' Fixed Column
    Dim vc As Long ' Value Column
    
    ' Write headers.
    For fc = 1 To cCount
        dData(dr, fc) = sData(1, fc)
    Next fc
    
    ' Write rest.
    If IncludeBlanks Then ' all
        For sr = 2 To srCount
            For vc = fvCol To cCount
                dr = dr + 1
                dData(dr, vc) = sData(sr, vc)
                For fc = 1 To FixedColumnsCount
                    dData(dr, fc) = sData(sr, fc)
                Next fc
            Next vc
        Next sr
    Else ' non-blank
        For sr = 2 To srCount
            For vc = fvCol To cCount
                If Len(CStr(sData(sr, vc))) > 0 Then
                    dr = dr + 1
                    dData(dr, vc) = sData(sr, vc)
                    For fc = 1 To FixedColumnsCount
                        dData(dr, fc) = sData(sr, fc)
                    Next fc
                End If
            Next vc
        Next sr
    End If
    
    GetTransformOneValuePerRow = dData
    
ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function

How do can I turn some rows of input into multiple new rows depending row contents with VBA/macros?

2 Answers

Transform Data: One Value Per Row