将Excel数组公式转换为VBA代码

Question

我有两组范围，分别命名为LIST_KEY和LIST_CAT。在A列中，用户将添加一些数据，这些数据将包含LIST_KEY中的一个文本。我想根据键值从LIST_CAT获取相应的类别列表

​

​

我使用下面的VBA代码来实现这一点。这包括一个数组公式。

Sub match()

Dim ss As Workbook

Dim test As Worksheet

Set ss = Excel.Workbooks("test.xlsm")
Set test = ss.Worksheets("Sheet1")

For i = 2 To test.Cells(Rows.Count, "A").End(xlUp).Row

Cells(i, "B").FormulaArray = "=INDEX(LIST_CAT,MATCH(TRUE,ISNUMBER(SEARCH(LIST_KEY,RC[-1])),0))"

Cells(i, "B").Formula = Cells(i, "B").Value

Next i

End Sub

如果要获取的数据较少，则此代码可以完美工作。但在我最初的用例中，我将有大约8000行。由于有大量的列，excel将在2-3分钟后进入无响应状态。

不是将数组公式添加到列B中，而是将其转换为VBA以更快地运行。对不起，我是VBA的新手，没有太多经验

Answer 1

尝试下面的代码，它使用数组而不是工作表公式...

Option Explicit

Sub GetCategories()

    Dim sourceWorkbook As Workbook
    Set sourceWorkbook = Workbooks("test.xlsm")

    Dim sourceWorksheet As Worksheet
    Set sourceWorksheet = sourceWorkbook.Worksheets("Sheet1")

    Dim lookupArray As Variant
    lookupArray = sourceWorkbook.Names("LIST_KEY").RefersToRange.Value

    Dim returnArray As Variant
    returnArray = sourceWorkbook.Names("LIST_CAT").RefersToRange.Value

    Dim tableArray As Variant
    Dim lastRow As Long
    With sourceWorksheet
        lastRow = .Cells(.Rows.Count, "a").End(xlUp).Row
        tableArray = .Range("A2:B" & lastRow).Value
    End With

    Dim desc As String
    Dim i As Long
    Dim j As Long
    For i = LBound(tableArray, 1) To UBound(tableArray, 1)
        desc = tableArray(i, 1)
        For j = LBound(lookupArray, 1) To UBound(lookupArray, 1)
            If InStr(1, desc, lookupArray(j, 1), vbTextCompare) > 0 Then
                tableArray(i, 2) = returnArray(j, 1)
                Exit For
            End If
        Next j
    Next i

    sourceWorksheet.Range("B2").Resize(UBound(tableArray, 1), 1).Value = Application.Index(tableArray, 0, 2)

End Sub