主页 / computer / 问题 / 1703293
Accepted
wyatt7613
Asked: 2022-02-05 21:15:12 +0800 CST

Excel VBA - 动态数组不起作用

  • 772

我正在尝试创建一个数组来存储“工作簿 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 列中有此代码正在写入的文本。

microsoft-excel worksheet-function

2 个回答

  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

    当然，真正的代码应该更长 - 例如，您需要检查工作簿“文件路径”是否存在并打开，是否有一个名为“工作表”的工作表，那里是否有数据等等

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

    数组代码会有点长，因为我们需要一个辅助过程来填充它和一个函数来搜索它。

    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

    辅助代码的诀窍是使用二分搜索，这比您在逐个元素地遍历未排序的数组时使用的线性搜索要快得多。

    要在没有帮助代码的情况下实现这个技巧，您可以使用Dictionary 对象- 它已经存在，您不必担心自己的经典算法实现。

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

    • 1
  2. Best Answer

    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”时，它把它放在了错误的文件中。所以我必须在执行代码之前重新激活我想要的文件。

    • 0

相关问题