2

I really appreciate any help I can get on this.

I'm trying to loop through a column looking for duplicate names then taking that and several of other data from same row and placing them into an 2D array that I want to use another function, but it's not working.

I really need your help figuring out why I cannot redim this array without preserving the data.

Dim oRange As Range, aCell As Range, bCell As Range
Dim ws As Worksheet
Dim SearchString As String, FoundAt As String
Dim tArray() As Variant
Dim iR As Long
Dim LastRow As Long
Dim LastCol As Long

'name of the worksheet
Set ws = Worksheets("VML Daily")

'column 6 has a huge list of names
Set oRange = ws.Columns(6)

'the keyword (there are 7 'ABC Company 1' in the column above)
SearchString = "ABC Company 1"

'Find keyword in column
Set aCell = oRange.Find(What:=SearchString, LookIn:=xlValues, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

'find last row and column number
LastRow = Range("A1").End(xlDown).Row

'redimensioning based on maximum rows
ReDim Preserve tArray(1 To LastRow, 1 To 3) As Variant

'if search finds something
If Not aCell Is Nothing Then
    Set bCell = aCell
    FoundAt = aCell.Address
    iR = 1

    tArray(1, 1) = aCell
    tArray(1, 2) = aCell.Offset(0, 33)
    tArray(1, 3) = aCell.Offset(0, 38)

    'continue finding stuff until end
    Do
        Set aCell = oRange.FindNext(After:=aCell)

        If Not aCell Is Nothing Then
            If aCell.Address = bCell.Address Then Exit Do
            FoundAt = FoundAt & ", " & aCell.Address
            tArray(iR, 1) = aCell
            tArray(iR, 2) = aCell.Offset(0, 33)
            tArray(iR, 3) = aCell.Offset(0, 38)
            iR = iR + 1
        Else
            Exit Do
        End If
    Loop

    'redim'ing the array to the amount of hits I found above and preserve the data
    'Here's where it error's out as "Subscript out of range"
    ReDim Preserve tArray(1 To iR, 1 To 3) As Variant
Else
    MsgBox SearchString & " not Found"
    Exit Sub
End If
Humble Val
  • 379
  • 2
  • 8
  • 17

1 Answers1

7

Your second Redim doesn't work because what you're doing is not possible.

From: Excel VBA - How to Redim a 2D array?

When Redimensioning multi-dimensional arrays, if you want to preserve your values, you can only increase the last dimension.

Changing the first element of your array while also calling Preserve always throws a subscript out of range error.

Sub Example()
    Dim val() As Variant
    ReDim val(1 To 2, 1 To 3)
    ReDim Preserve val(1 To 2, 1 To 4) 'Fine
    ReDim Preserve val(1 To 2, 1 To 2) 'also Fine
    ReDim Preserve val(1 To 3, 1 To 3) 'Throws error
    ReDim Preserve val(1 To 1, 1 To 3) 'Also throws error
End Sub

Edit: Since you aren't actually changing the last dimension, you can rework your code simply by swapping which dimension you're changing.

For instance:

ReDim Preserve tArray(1 To LastRow, 1 To 3) As Variant and

ReDim Preserve tArray(1 To iR, 1 To 3) As Variant

become

ReDim Preserve tArray(1 To 3, 1 To LastRow) As Variant and

ReDim Preserve tArray(1 To 3, 1 To iR) As Variant

You'll just need to swap the numbers you use in each call, and it should work as expected. LIke so:

tArray(1, iR) = aCell
tArray(2, iR) = aCell.Offset(0, 33)
tArray(3, iR) = aCell.Offset(0, 38)
Community
  • 1
  • 1
Daniel
  • 12,982
  • 3
  • 36
  • 60
  • Ah, so basically there is no way to keep the last dimension from changing and would have to increase it every time. I'm definitely using the wrong concept to add values into an array. Is there a way to use dynamic array instead? I just want to be able to add values into an array until it's done and then loop it back when necessary. – Humble Val Dec 18 '13 at 21:08
  • Based on your code, you should be fine if you change your first element to the one that doesn't change. I'll update to reflect that... – Daniel Dec 18 '13 at 21:14
  • 1
    like I said +1 @DanielCook great answer I've learned something new from it:) –  Dec 19 '13 at 08:05
  • 1
    @mehow I want to thank you as well for your contributions, much appreciated. – Humble Val Dec 19 '13 at 19:07