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:
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?
CodePudding user response:
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
CodePudding user response:
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