Expanding column cells for each column cell

by

I gather by universal, you want this to accommodate any number of columns and any number of entries in each. A few variant arrays should provide the dimensions necessary to calculate the cycles of repetition for each value.

Option Explicit

Sub main()
    Call for_each_in_others(rDATA:=Worksheets("Sheet3").Range("A3"), bHDR:=True)
End Sub

Sub for_each_in_others(rDATA As Range, Optional bHDR As Boolean = False)
    Dim v As Long, w As Long
    Dim iINCROWS As Long, iMAXROWS As Long, sErrorRng As String
    Dim vVALs As Variant, vTMPs As Variant, vCOLs As Variant

    On Error GoTo bm_Safe_Exit
    appTGGL bTGGL:=False

    With rDATA.Parent
        With rDATA(1).CurrentRegion
            'Debug.Print rDATA(1).Row - .Cells(1).Row
            With .Resize(.Rows.Count - (rDATA(1).Row - .Cells(1).Row), .Columns.Count).Offset(2, 0)
                sErrorRng = .Address(0, 0)
                vTMPs = .Value2
                ReDim vCOLs(LBound(vTMPs, 2) To UBound(vTMPs, 2))
                iMAXROWS = 1
                'On Error GoTo bm_Output_Exceeded
                For w = LBound(vTMPs, 2) To UBound(vTMPs, 2)
                    vCOLs(w) = Application.CountA(.Columns(w))
                    iMAXROWS = iMAXROWS * vCOLs(w)
                Next w

                'control excessive or no rows of output
                If iMAXROWS > Rows.Count Then
                    GoTo bm_Output_Exceeded
                ElseIf .Columns.Count = 1 Or iMAXROWS = 0 Then
                    GoTo bm_Nothing_To_Do
                End If

                On Error GoTo bm_Safe_Exit
                ReDim vVALs(LBound(vTMPs, 1) To iMAXROWS, LBound(vTMPs, 2) To UBound(vTMPs, 2))
                iINCROWS = 1
                For w = LBound(vVALs, 2) To UBound(vVALs, 2)
                    iINCROWS = iINCROWS * vCOLs(w)
                    For v = LBound(vVALs, 1) To UBound(vVALs, 1)
                        vVALs(v, w) = vTMPs((Int(iINCROWS * ((v - 1) / UBound(vVALs, 1))) Mod vCOLs(w)) + 1, w)
                    Next v
                Next w
            End With
        End With
        .Cells(2, UBound(vVALs, 2) + 2).Resize(1, UBound(vVALs, 2) + 2).EntireColumn.Delete
        If bHDR Then
            rDATA.Cells(1, 1).Offset(-1, 0).Resize(1, UBound(vVALs, 2)).Copy _
                Destination:=rDATA.Cells(1, UBound(vVALs, 2) + 2).Offset(-1, 0)
        End If
        rDATA.Cells(1, UBound(vVALs, 2) + 2).Resize(UBound(vVALs, 1), UBound(vVALs, 2)) = vVALs
    End With

    GoTo bm_Safe_Exit
bm_Nothing_To_Do:
    MsgBox "There is not enough data in  " & sErrorRng & " to perform expansion." & Chr(10) & _
           "This could be due to a single column of values or one or more blank column(s) of values." & _
            Chr(10) & Chr(10) & "There is nothing to expand.", vbInformation, _
           "Single or No Column of Raw Data"
    GoTo bm_Safe_Exit
bm_Output_Exceeded:
    MsgBox "The number of expanded values created from " & sErrorRng & _
           " (" & Format(iMAXROWS, "\> #, ##0") & " rows × " & UBound(vTMPs, 2) & _
           " columns) exceeds the rows available (" & Format(Rows.Count, "#, ##0") & ") on this worksheet.", vbCritical, _
           "Too Many Entries"
bm_Safe_Exit:
    appTGGL
End Sub

Sub appTGGL(Optional bTGGL As Boolean = True)
    Application.EnableEvents = bTGGL
    Application.ScreenUpdating = bTGGL
End Sub

Put the column header labels in row 2 starting in column A and the data directly below that.

I have added some error control to warn of exceeding the number of rows on a worksheet. This is not normally something that is likely to be a consideration but multiplying the number of values in an undetermined number of columns against each other can quickly produce a large number of results. It is not unforeseeable that you would exceed 1,048,576 rows.

        Variant Array expansion

More Related Contents:

  1. Performance difference between looping range vs looping array
  2. Excel-VBA – Insert new first column in datafield array without loops or API calls
  3. Creating an Array from a Range in VBA
  4. How do I slice an array in Excel VBA?
  5. Check if a value is in an array or not with Excel VBA
  6. Matching values in string array
  7. Deleting Elements in an Array if Element is a Certain value VBA
  8. Is it possible to fill an array with row numbers which match a certain criteria without looping?
  9. How to automatically input an array formula as string with more than 255 characters in length into an excel cell using VBA?
  10. Return Index of an Element in an Array Excel VBA
  11. Writing an array to a range. Only getting first value of array
  12. Excel VBA: Range to String Array in 1 step
  13. Faster way of using Sumifs()
  14. How to initialize a multidimensional array variable in vba for excel
  15. VBA using ubound on a multidimensional array
  16. Turn Excel range into VBA string
  17. Get values from union of non-contiguous ranges into array with VBA with a simple command (no loops)
  18. Why am I having issues assigning a Range to an Array of Variants
  19. Subscript out of range error with an array – no idea why?
  20. VBA Excel large data manipulation taking forever
  21. Create Chart from Array data and not range
  22. Excel VBA Quickest way to sort an array of numbers in descending order?
  23. Simple VBA array join not working
  24. Excel VBA – How to Redim a 2D array?
  25. ReDim Preserve “Subscript Out of Range”
  26. Iterate over two arrays simultaneously in bash
  27. Loop through each row of a range in Excel
  28. How to keep associative array order?
  29. Dynamically Dimensioning A VBA Array?
  30. VBA – Returning array from Property Get

Leave a Comment