Hello from NZ!
I have been struggling away trying to write a user defined function and thought I'd see if anyone here could help.
My goal is to take a 2d array and split out any rows with more than 1 non-zero value into two rows. See the images below for an example of what I'm looking to accomplish.
Input Array:
Desired Output Array:
I'm open to any solutions for this, but it needs to be dynamic as the workbook updates so either built in functions or custom functions.
Here is what I have so far in my custom function (helped by chatGPT). It keeps giving VALUE errors when I try to use it and when I added a driver function to step through it I was getting Subscript out of range errors. Any help would be awesome!
Function SplitRows(arr As Variant) As Variant
Dim i As Long, j As Long, k As Long
Dim nonZeroCount As Long
Dim result() As Variant
Dim resultRow As Long
Dim numRows As Long
Dim numCols As Long
' Determine the number of rows and columns in the input array
numRows = UBound(arr, 1)
numCols = UBound(arr, 2)
' Initialize the result array with enough rows
ReDim result(1 To 1, 1 To numCols)
resultRow = 1
For i = LBound(arr, 1) To numRows
' Count non-zero values in the current row
nonZeroCount = 0
For j = LBound(arr, 2) To numCols
If arr(i, j) <> 0 Then
nonZeroCount = nonZeroCount + 1
End If
Next j
' If there are no non-zero values, copy the row as is
If nonZeroCount = 0 Then
If resultRow > UBound(result, 1) Then
ReDim Preserve result(1 To resultRow, 1 To numCols)
End If
For j = LBound(arr, 2) To numCols
result(resultRow, j) = arr(i, j)
Next j
resultRow = resultRow + 1
Else
' Create rows for each non-zero value
For j = LBound(arr, 2) To numCols
If arr(i, j) <> 0 Then
If resultRow > UBound(result, 1) Then
ReDim Preserve result(1 To resultRow, 1 To numCols)
End If
For k = LBound(arr, 2) To numCols
If k = j Then
result(resultRow, k) = arr(i, k)
Else
result(resultRow, k) = 0
End If
Next k
resultRow = resultRow + 1
End If
Next j
End If
Next i
SplitRows = result
End Function
I have been struggling away trying to write a user defined function and thought I'd see if anyone here could help.
My goal is to take a 2d array and split out any rows with more than 1 non-zero value into two rows. See the images below for an example of what I'm looking to accomplish.
Input Array:
Desired Output Array:
I'm open to any solutions for this, but it needs to be dynamic as the workbook updates so either built in functions or custom functions.
Here is what I have so far in my custom function (helped by chatGPT). It keeps giving VALUE errors when I try to use it and when I added a driver function to step through it I was getting Subscript out of range errors. Any help would be awesome!
Function SplitRows(arr As Variant) As Variant
Dim i As Long, j As Long, k As Long
Dim nonZeroCount As Long
Dim result() As Variant
Dim resultRow As Long
Dim numRows As Long
Dim numCols As Long
' Determine the number of rows and columns in the input array
numRows = UBound(arr, 1)
numCols = UBound(arr, 2)
' Initialize the result array with enough rows
ReDim result(1 To 1, 1 To numCols)
resultRow = 1
For i = LBound(arr, 1) To numRows
' Count non-zero values in the current row
nonZeroCount = 0
For j = LBound(arr, 2) To numCols
If arr(i, j) <> 0 Then
nonZeroCount = nonZeroCount + 1
End If
Next j
' If there are no non-zero values, copy the row as is
If nonZeroCount = 0 Then
If resultRow > UBound(result, 1) Then
ReDim Preserve result(1 To resultRow, 1 To numCols)
End If
For j = LBound(arr, 2) To numCols
result(resultRow, j) = arr(i, j)
Next j
resultRow = resultRow + 1
Else
' Create rows for each non-zero value
For j = LBound(arr, 2) To numCols
If arr(i, j) <> 0 Then
If resultRow > UBound(result, 1) Then
ReDim Preserve result(1 To resultRow, 1 To numCols)
End If
For k = LBound(arr, 2) To numCols
If k = j Then
result(resultRow, k) = arr(i, k)
Else
result(resultRow, k) = 0
End If
Next k
resultRow = resultRow + 1
End If
Next j
End If
Next i
SplitRows = result
End Function
