A better way to fill a 2D Array?

[David Condit]

Hi, all! This is my first post on your forum. While searching for misc VBA answers on google I've often been directed to this site, so I opted to register; I hope one of you can help me solve my current problem.

Is there a better way to fill a 2D array than what I have coded below? It seems I should be able to fill a 2D array from a multi-row single-column range without needing an If...Then...Else or Select Case statement. Any help would be appreciated!

Sub ColorsArrayTest()   ' Fills a 2D array from a 1D named range.


    Dim Rng As Range
    Dim TempArr As Variant
    Dim r As Long, c As Long, MaxRow As Long
    Dim msg As String
    
    ' Assign Rng to a R6C1 named range, "Colors."
    Set Rng = Worksheets("Sheet1").Range("Colors")
    
    ' Fill a 2D Array (6 rows, 2 columns) with
    ' Rng's value property in column 1 and Rng's
    ' address property in column.
    '
    ' Is there a better way to do this??? Surely there's
    ' a better way to fill a 2d array besides validating
    ' the array element with an If or Select Case statement
    ' after each loop... help me!
    MaxRow = Rng.Rows.Count
    ReDim TempArr(1 To MaxRow, 1 To 2)
    For r = 1 To MaxRow
        For c = 1 To 2
            If c = 1 Then
                TempArr(r, c) = Rng(r, c).Value
                msg = msg & TempArr(r, c) & vbTab
            Else
                TempArr(r, c) = Rng(r, 1).Address
                msg = msg & TempArr(r, c) & vbCrLf
            End If
        Next c
    Next r
    
    ' Spits out the Colors named range values
    ' and its values' address properties in
    ' two columns.
    MsgBox msg
           
    

End Sub

 

[Rick Rothstein]

Here is a non-looping method to do what you want (note the test code at the end contains a loop, but all of that code should be deleted once you are satisfied the code above does what you want)...

Sub ColorsArrayTest()   ' Fills a 2D array from a 1D named range.
  Dim Rng As Range, ColorsArray As Variant
  Application.ScreenUpdating = False
  Set Rng = Range("Colors")
  Rng.Columns.Offset(, 1).EntireColumn.Insert
  Rng.Offset(, 1).Value = Evaluate("IF(LEN(" & Rng.Address & "),ADDRESS(ROW(" & _
                          Rng.Address & "),COLUMN(" & Rng.Address & ")),"""")")
  ColorsArray = Rng.Resize(, 2)
  Rng.Columns.Offset(, 1).EntireColumn.Delete
  Application.ScreenUpdating = True
  '
  '  At this point, ColorsArray is a 2-dimensional array with the value from
  '  the cell in the first elements and the cell address in the second elements
  '

  '
  '  Test code to see if that is true (DELETE after you are satisfied it works)...
  '
  Dim X As Long, Msg As String
  For X = 1 To UBound(ColorsArray)
    Msg = Msg & ColorsArray(X, 1) & " - " & ColorsArray(X, 2) & vbLf
  Next
  MsgBox Msg
End Sub

 

[David Condit]

Here is a non-looping method to do what you want (note the test code at the end contains a loop, but all of that code should be deleted once you are satisfied the code above does what you want)...

Wow. This is really clever, Rick! I'll have to add the Resize property and Evaluate method to my repertoire.

Though I imagine your solution is faster than any loop since there are less lines of code to run through, is there a better loop solution than the one I came up with? Maybe not, but I'd love to know.

 

[Rick Rothstein]

Wow. This is really clever, Rick! I'll have to add the Resize property and Evaluate method to my repertoire.

Actually, I got a more clever idea just now... here is my original code modified so that a column does not have to be inserted and later deleted, thus removing the requirement to turn off (and then back on) ScreenUpdating which, in turn, shortens the active code in my macro dramatically (down to two active lines of code)...

Sub ColorsArrayTest()   ' Fills a 2D array from a 1D named range.
  Dim Rng As Range, ColorsArray As Variant
  Set Rng = Range("Colors").Resize(, 2)
  ColorsArray = Evaluate("IF(LEN(" & Rng.Columns(1).Address & "),IF(COLUMN(" & Rng.Address & ")=" & _
                Rng.Column & "," & Rng.Address & ",ADDRESS(ROW(" & Rng.Offset(, -1).Address & _
                "),COLUMN(" & Rng.Offset(, -1).Address & "))),"""")")
  '
  '  At this point, ColorsArray is a 2-dimensional array with the value from
  '  the cell in the first elements and the cell address in the second elements
  '

 '
  '  Test code to see if that is true (DELETE after you are satisfied it works)...
  '
  Dim X As Long, Msg As String
  For X = 1 To UBound(ColorsArray)
    Msg = Msg & ColorsArray(X, 1) & " - " & ColorsArray(X, 2) & vbLf
  Next
  MsgBox Msg
End Sub

 

[Rick Rothstein]

...is there a better loop solution than the one I came up with?

I am not sure if the "more clever" code I just posted in Message #4 is faster than the code below or not, but the code below does answer your quoted question above (well, at least I think it is a better solution)...

Sub ColorsArrayTest()   ' Fills a 2D array from a 1D named range.
  Dim X As Long, StartRow As Long, ColorsColumn As Long, RngArray As Variant, ColorsArray As Variant
  RngArray = Range("Colors")
  StartRow = Range("Colors")(1).Row
  ColorsColumn = Range("Colors").Column
  ReDim ColorsArray(1 To UBound(RngArray), 2)
  For X = 1 To UBound(RngArray)
    ColorsArray(X, 1) = RngArray(X, 1)
    If Len(ColorsArray(X, 1)) Then ColorsArray(X, 2) = Cells(StartRow + X - 1, ColorsColumn).Address
  Next
  '
  '  At this point, ColorsArray is a 2-dimensional array with the value from
  '  the cell in the first elements and the cell address in the second elements
  '

 '
  '  Test code to see if that is true (DELETE after you are satisfied it works)...
  '
  Dim Msg As String
  For X = 1 To UBound(ColorsArray)
    Msg = Msg & ColorsArray(X, 1) & " - " & ColorsArray(X, 2) & vbLf
  Next
  MsgBox Msg
End Sub

 

[David Condit]

Rick, thanks again; I'll have to check out your new alternate solutions tonight!

I had another go at it and I think this works reasonably well, too:

Sub ColorsArrayTest3()
    
    Dim Rng As Range
    Dim ColorsArray As Variant
    Dim MaxRow As Long, i As Long
    
    Set Rng = Range("Colors")
    MaxRow = Rng.Rows.Count
    
    ReDim ColorsArray(1 To MaxRow, 1 To 3)
    
    ' This is a bit manual since the 2nd dimension of each ColorsArray
    ' element is hand-keyed, but this works without needing to qualify where
    ' I'm at in the loop.
    ' Note: Address and Width attributes were chosen to fill up the array. They
    ' don't mean anything. 
    For i = 1 To MaxRow
        ColorsArray(i, 1) = Rng(i, 1).Value
        ColorsArray(i, 2) = Rng(i, 1).Address
        ColorsArray(i, 3) = Rng(i, 1).Width 
    Next i
    
End Sub

Random thought: The traffic on this site is incredible. I had to skim through 3 pages of new posts before I could find the thread I submitted just last night!

 

[Rick Rothstein]

Random thought: The traffic on this site is incredible. I had to skim through 3 pages of new posts before I could find the thread I submitted just last night!

Click your name at the top of the webpage (it's a link) and click the "My Activity" tab and then the "All" tab... you should be able to find your messages easier that way.

 

[mugginsjr]

Actually, I got a more clever idea just now... here is my original code modified so that a column does not have to be inserted and later deleted, thus removing the requirement to turn off (and then back on) ScreenUpdating which, in turn, shortens the active code in my macro dramatically (down to two active lines of code)...

Sub ColorsArrayTest()   ' Fills a 2D array from a 1D named range.
  Dim Rng As Range, ColorsArray As Variant
  Set Rng = Range("Colors").Resize(, 2)
  ColorsArray = Evaluate("IF(LEN(" & Rng.Columns(1).Address & "),IF(COLUMN(" & Rng.Address & ")=" & _
                Rng.Column & "," & Rng.Address & ",ADDRESS(ROW(" & Rng.Offset(, -1).Address & _
                "),COLUMN(" & Rng.Offset(, -1).Address & "))),"""")")
  '
  '  At this point, ColorsArray is a 2-dimensional array with the value from
  '  the cell in the first elements and the cell address in the second elements
  '

 '
  '  Test code to see if that is true (DELETE after you are satisfied it works)...
  '
  Dim X As Long, Msg As String
  For X = 1 To UBound(ColorsArray)
    Msg = Msg & ColorsArray(X, 1) & " - " & ColorsArray(X, 2) & vbLf
  Next
  MsgBox Msg
End Sub

I was just passing by looking for something similar and had to stop and say "Wow!" Kudos on that sir! your code is awesome.

 

[Rick Rothstein]

I was just passing by looking for something similar and had to stop and say "Wow!" Kudos on that sir! your code is awesome.

Thank you for your kind words... I really appreciate them.