Excel VBA - ошибка времени выполнения «9», подзаголовок вне допустимого диапазона

Question

Я очень ценю любую помощь, которую я могу получить.

Я пытаюсь пройти через столбец, ищущий повторяющиеся имена, затем беря это и несколько других данных из одной строки и помещая их в 2D-массив, который я хочу использовать другой функцией, но он не работает.

Мне очень нужна ваша помощь в выяснении, почему я не могу переделать этот массив без сохранения данных.

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 

Answer 1

Ваш второй Redim не работает, потому что то, что вы делаете, невозможно.

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

Когда Redimensioning многомерных массивов, если вы хотите сохранить свои ценности, вы можете только увеличить размер последнего.

Изменение первого элемента вашего массива при одновременном вызове Preserve всегда выдает ошибку индексации вне диапазона.

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: Так как вы на самом деле не меняется последнее измерение, вы можете переделать код просто свопинга, какое измерение вы изменяете.

Например:

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

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

стать

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

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

You Вам просто нужно поменять номера, которые вы используете в каждом вызове, и он должен работать так, как ожидалось. LIke so:

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