使用FindNext中填寫多維數組VBA的Excel

Question

我的問題實際上涉及的是對EXCEL VBA Store search results in an array?

這裏安德烈亞斯試圖通過一列搜索和點擊保存到一個數組延伸的問題。我正在嘗試。但不同之處在於：（1）找到一個值（2）我想從（3）單元格中找到與搜索到的值相同的行中的不同值類型，（4）複製到二維數組中。

所以該數組（概念上）看起來像：

Searchresult.1st SameRow.Cell1.Value1 SameRow.Cell2.Value2 SameRow.Cell3.Value3 
Searchresult.2nd SameRow.Cell1.Value1 SameRow.Cell2.Value2 SameRow.Cell3.Value3 
Searchresult.3rd SameRow.Cell1.Value1 SameRow.Cell2.Value2 SameRow.Cell3.Value3 

Etc. 

我使用的代碼如下所示：

Sub fillArray() 

Dim i As Integer 
Dim aCell, bCell As Range 
Dim arr As Variant 

i = 0 

Set aCell = Sheets("Log").UsedRange.Find(What:=("string"), _ 
        LookIn:=xlValues, _ 
        LookAt:=xlWhole, _ 
        SearchOrder:=xlByRows, _ 
        SearchDirection:=xlNext, _ 
        MatchCase:=False, _ 
        SearchFormat:=False) 

If Not aCell Is Nothing Then 
    Set bCell = aCell 
    ReDim Preserve arr(i, 5) 
    arr(i, 0) = True 'Boolean 
    arr(i, 1) = aCell.Value 'String 
    arr(i, 2) = aCell.Cells.Offset(0, 1).Value 
    arr(i, 3) = aCell.Cells.Offset(0, 3).Value 
    arr(i, 4) = aCell.Cells.Offset(0, 4).Value 
    arr(i, 5) = Year(aCell.Cells.Offset(0, 3).Value) 

    i = i + 1 

    Do While exitLoop = False 
      Set aCell = Sheets("Log").UsedRange.FindNext(after:=aCell) 

      If Not aCell Is Nothing Then 
       If aCell.Address = bCell.Address Then Exit Do 
       'ReDim Preserve arrSwUb(i, 5) 
        arr(i, 0) = True 
        arr(i, 1) = aCell.Value 
        arr(i, 2) = aCell.Cells.Offset(0, 1).Value 
        arr(i, 3) = aCell.Cells.Offset(0, 3).Value 
        arr(i, 4) = aCell.Cells.Offset(0, 4).Value 
        arr(i, 5) = Year(aCell.Cells.Offset(0, 3).Value) 

        i = i + 1 
      Else 
       exitLoop = True 
      End If 
    Loop 


End If 

End Sub 

看來出問題的redimming在循環數組。我得到一個下標超出範圍錯誤。我想我不能像現在做的那樣重新設置數組，但我無法弄清楚它應該如何完成。

我對任何線索都很有幫助，因爲我做錯了什麼。

Answer 1

使用ReDim保留只能調整您的數組的最後一維： http://msdn.microsoft.com/en-us/library/w8k3cys2(v=vs.71).aspx

從上面的鏈接：

保留

Optional. Keyword used to preserve the data in the existing array when you change the size of only the last dimension.

編輯： 這不是是非常有幫助的。我建議你調換你的數組。此外，來自數組函數的錯誤消息是AWFUL。

在Siddarth的建議下，試試這個。讓我知道如果您有任何問題：

Sub fillArray() 
    Dim i As Integer 
    Dim aCell As Range, bCell As Range 
    Dim arr As Variant 

    i = 0 
    Set aCell = Sheets("Log").UsedRange.Find(What:=("string"), _ 
              LookIn:=xlValues, _ 
              LookAt:=xlWhole, _ 
              SearchOrder:=xlByRows, _ 
              SearchDirection:=xlNext, _ 
              MatchCase:=False, _ 
              SearchFormat:=False) 
    If Not aCell Is Nothing Then 
     Set bCell = aCell 
     ReDim Preserve arr(0 To 5, 0 To i) 
     arr(0, i) = True 'Boolean 
     arr(1, i) = aCell.Value 'String 
     arr(2, i) = aCell.Cells.Offset(0, 1).Value 
     arr(3, i) = aCell.Cells.Offset(0, 3).Value 
     arr(4, i) = aCell.Cells.Offset(0, 4).Value 
     arr(5, i) = Year(aCell.Cells.Offset(0, 3).Value) 
     i = i + 1 
     Do While exitLoop = False 
      Set aCell = Sheets("Log").UsedRange.FindNext(after:=aCell) 
      If Not aCell Is Nothing Then 
       If aCell.Address = bCell.Address Then Exit Do 
       ReDim Preserve arrSwUb(0 To 5, 0 To i) 
       arr(0, i) = True 
       arr(1, i) = aCell.Value 
       arr(2, i) = aCell.Cells.Offset(0, 1).Value 
       arr(3, i) = aCell.Cells.Offset(0, 3).Value 
       arr(4, i) = aCell.Cells.Offset(0, 4).Value 
       arr(5, i) = Year(aCell.Cells.Offset(0, 3).Value) 
       i = i + 1 
      Else 
       exitLoop = True 
      End If 
     Loop 
    End If 
End Sub 

注：在聲明中，您必須：

Dim aCell, bCell as Range 

這是一樣的：

Dim aCell as Variant, bCell as Range 

一些測試代碼來證明以上：

Sub testTypes() 

    Dim a, b As Integer 
    Debug.Print VarType(a) 
    Debug.Print VarType(b) 

End Sub 

Answer 2

你不能Redim Preserve這樣的多維數組。在多維數組中，當您使用Preserve時，只能更改最後一個維度。如果您嘗試更改任何其他維度，則會發生運行時錯誤。我建議閱讀本msdn鏈接

話說回來，我能想到的2個選項

選項1

將結果保存到一個新的臨時表

選項2

聲明一維數組，然後使用唯一分隔符連接結果，例如"#Evert_Van_Steen#"

在代碼

Const Delim As String = "#Evert_Van_Steen#" 

的頂部，然後使用它像這樣

ReDim Preserve arr(i) 

arr(i) = True & Delim & aCell.Value & Delim & aCell.Cells.Offset(0, 1).Value & Delim & _ 
aCell.Cells.Offset(0, 3).Value & Delim & aCell.Cells.Offset(0, 4).Value & Delim & _ 
Year(aCell.Cells.Offset(0, 3).Value) 

Answer 3

這裏有一個假設，你可以在開始維度數組的選項。我用了一個UsedRange爲WorsheetFunction.Countif「弦」，這似乎像它應該工作：

Option Explicit 

    Sub fillArray() 

    Dim i As Long 
    Dim aCell As Range, bCell As Range 
    Dim arr() As Variant 
    Dim SheetToSearch As Excel.Worksheet 
    Dim StringCount As Long 

    Set SheetToSearch = ThisWorkbook.Worksheets("log") 
    i = 1 

    With SheetToSearch 
     StringCount = Application.WorksheetFunction.CountIf(.Cells, "string") 
     ReDim Preserve arr(1 To StringCount, 1 To 6) 
     Set aCell = .UsedRange.Find(What:=("string"), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) 

     If Not aCell Is Nothing Then 
      arr(i, 1) = True 'Boolean 
      arr(i, 2) = aCell.Value 'String 
      arr(i, 3) = aCell.Cells.Offset(0, 1).Value 
      arr(i, 4) = aCell.Cells.Offset(0, 3).Value 
      arr(i, 5) = aCell.Cells.Offset(0, 4).Value 
      arr(i, 6) = Year(aCell.Cells.Offset(0, 3).Value) 
      Set bCell = aCell 
      i = i + 1 

      Do Until i > StringCount 
       Set bCell = .UsedRange.FindNext(after:=bCell) 
       If Not bCell Is Nothing Then 
        arr(i, 1) = True 'Boolean 
        arr(i, 2) = bCell.Value 'String 
        arr(i, 3) = bCell.Cells.Offset(0, 1).Value 
        arr(i, 4) = bCell.Cells.Offset(0, 3).Value 
        arr(i, 5) = bCell.Cells.Offset(0, 4).Value 
        arr(i, 6) = Year(bCell.Cells.Offset(0, 3).Value) 
        i = i + 1 
       End If 
      Loop 
     End If 
    End With 

    End Sub 

請注意，我在你的聲明固定的一些問題。我添加了Option Explicit，這會強制你聲明你的變量 - exitLoop是未聲明的。現在aCell和bCell都是範圍 - previously only bCell was（向下滾動到「注意變量聲明一個暗語」）。我還創建了一個工作表變量並將其包含在With語句中。另外，我開始將數組的兩個維度都設置爲1，因爲...因爲我想我想:)。我也簡化了一些退出邏輯的循環 - 我不認爲你需要所有這些來告訴什麼時候退出。