☰

Excel VBA - 动态数组不起作用

tag-icon • tag-icon microsoft-excel worksheet-function microsoft-excel-2010 vba array
Excel VBA - 动态数组不起作用

我正在尝试创建一个数组，存储“工作簿 B”中 A 列中的所有值，以便我可以引用并查看单元格的值是否位于“工作簿 A”中 A 列中的该数组中。

这是我目前所掌握的该阵列的内容：

Dim StrArray() As String
Dim TotalRows As Long
Dim X As Long

Workbooks.Open Filename:="filepath", ReadOnly:=True

With Workbooks("file").Worksheets("sheet")
    TotalRows = Rows(Rows.Count).End(xlUp).Row
    ReDim StrArray(1 To TotalRows)
    For X = 2 To TotalRows
        StrArray(X) = Cells(X, 1).Value
    Next X
End With

数组的这一部分工作正常，我通过在 MsgBox 中显示数组中的所有值来确认它工作正常。当我尝试在“工作簿 A”中引用此数组以检查单元格的值是否在该数组中时，问题就出现了。

这是我所得到的该代码：

For RowCounter = LastRow To 1 Step -1
    If IsInArray(Range("B" & RowCounter).Value, StrArray) Then
        Range("K" & RowCounter).Value = "MATCH"
    End If
Next RowCounter

Workbooks("file").Close SaveChanges:=False

这是我正在使用的功能：

Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
    Dim i
    For i = LBound(arr) To UBound(arr)
        If arr(i) = stringToBeFound Then
            IsInArray = True
            Exit Function
        End If
    Next i
    IsInArray = False

End Function

它没有将“MATCH”值放在 K 列中。我尝试通过在 If 语句中放置一个 MsgBox 来查看它是否将值与数组匹配，从而进行故障排除，但它给了我一个永无止境的 MsgBox 循环。如果这很重要，则 K 列中当前有文本被此代码覆盖。

答案1

如果我正在解决这样的问题，我会拒绝使用数组，而选择内置的MATCH 方法：

Sub markCellsIfPresent()
Const DICTIONARY_WORKBOOK As String = "filepath"
Const DICTIONARY_WORKSHEET = "sheet"
Dim wsActive As Worksheet
Dim rValidate As Range
Dim oCell As Range
Dim wbDictionary As Workbook
Dim wsDictionary As Worksheet
Dim rDictionary As Range
Dim searchRes As Variant

    Set wsActive = ActiveSheet
    Set rValidate = Application.Intersect(wsActive.UsedRange, wsActive.Columns(2))
    Application.ScreenUpdating = False
    Set wbDictionary = Workbooks.Open(Filename:=DICTIONARY_WORKBOOK, ReadOnly:=True)
    Set wsDictionary = wbDictionary.Worksheets(DICTIONARY_WORKSHEET)
    Set rDictionary = Application.Intersect(wsDictionary.UsedRange, wsDictionary.Columns(1))
        
    For Each oCell In rValidate.Cells
        searchRes = Application.Match(oCell.Text, rDictionary, 0)
        If Not IsError(searchRes) Then
Rem oCell in column B (2), we set mark to column K (11), so offset is 11-2=9
           oCell.Offset(0, 9).value = "MATCH"
        End If
    Next oCell
   
    wbDictionary.Close
    Application.ScreenUpdating = True
End Sub

当然，真正的代码应该更长 - 例如，您需要检查工作簿“filepath”是否存在并打开，其中是否有名为“sheet”的工作表，其中是否有数据等等

这段代码解决了这个问题，但没有回答关于为此目的使用数组的问题。

数组代码将会更长一些，因为我们需要一个辅助程序来填充它和一个函数来搜索它。

Sub markCellsWithArray()
Const DICTIONARY_WORKBOOK As String = "filepath"
Const DICTIONARY_WORKSHEET = "sheet"
Dim wsActive As Worksheet
Dim rValidate As Range
Dim oCell As Range
Dim wbDictionary As Workbook
Dim wsDictionary As Worksheet
Dim rDictionary As Range
Dim StrArray As Variant

    Set wsActive = ActiveSheet
    Set rValidate = Application.Intersect(wsActive.UsedRange, wsActive.Columns(2))
    Application.ScreenUpdating = False
    Set wbDictionary = Workbooks.Open(Filename:=DICTIONARY_WORKBOOK, ReadOnly:=True)
    Set wsDictionary = wbDictionary.Worksheets(DICTIONARY_WORKSHEET)
    Set rDictionary = Application.Intersect(wsDictionary.UsedRange, wsDictionary.Columns(1))
Rem Collect values from dictionary to array (skip empty cells)
    StrArray = Array()
    For Each oCell In rDictionary.Cells
        If Not Trim(oCell.Text) = vbNullString Then Call AddIfNeed(Trim(oCell.Text), StrArray)
    Next oCell
    wbDictionary.Close
    Application.ScreenUpdating = True
Rem Mark cells in active sheet
    For Each oCell In rValidate.Cells
        If IsInArray(Trim(oCell.Text), StrArray) Then
           oCell.Offset(0, 9).value = "MATCH"
        End If
    Next oCell
End Sub
Sub AddIfNeed(ByVal key As String, aData As Variant)
Dim l&, r&, m&, N&, i&
    l = LBound(aData)
    r = UBound(aData) + 1
    N = r
    While (l < r)
        m = l + Int((r - l) / 2)
        If aData(m) < key Then l = m + 1 Else r = m
    Wend
    If r = N Then   ' Add to end of set
        ReDim Preserve aData(0 To N)
        aData(N) = key
    ElseIf aData(r) = key Then
' Already in the set, do nothing
    Else    ' Insert to set in correct place
        ReDim Preserve aData(0 To N)
        For i = N - 1 To r Step -1
            aData(i + 1) = aData(i)
        Next i
        aData(r) = key
    End If
End Sub

Private Function IsInArray(ByVal stringToBeFound As String, aData As Variant) As Boolean
Dim l&, r&, m&, N&, i&
    l = LBound(aData)
    r = UBound(aData) + 1
    N = r
    While (l < r)
        m = l + Int((r - l) / 2)
        If aData(m) < stringToBeFound Then l = m + 1 Else r = m
    Wend
    If r = N Then   ' Add to end of set
        IsInArray = False
    Else
        IsInArray = (aData(r) = stringToBeFound)    ' TRUE if found
    End If
End Function

辅助代码的诀窍是使用二分查找，这比线性搜索在逐个元素地浏览未排序数组时使用。

为了在没有辅助代码的情况下实现这个技巧，你可以使用字典对象- 一切都已存在，您不必担心自己对经典算法的实现。

但是，在足够大的数据集上测试这两个过程，看看数组算法如何胜过内置的 MATCH 方法。

答案2

JohnSUN 的代码运行良好，但我也弄清楚了如何让数组路径正常工作。

Workbooks.Open Filename:="filepath", ReadOnly:=True

    With Workbooks("filename").Worksheets("sheetname")
        TotalRows = Rows(Rows.Count).End(xlUp).Row
        ReDim StrArray(1 To TotalRows)
        For X = 2 To TotalRows
            StrArray(X) = Cells(X, 1).Value
        Next X
    End With

    Workbooks("filename").Close SaveChanges:=False

    ActWS.Activate

    'Adds MATCH to applicable rows
    For RowCounter = LastRow To 1 Step -1
        If IsInArray(Range("B" & RowCounter).Value, StrArray) Then
            Range("K" & RowCounter).Value = "MATCH"
        End If
    Next RowCounter
End If

问题是，当应用“MATCH”时，它会将其放入错误的文件中。因此，在执行代码之前，我必须重新激活我想要的文件。

相关内容