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

Question

I have two set of range named as LIST_KEY and LIST_CAT . In Column A, user will add some data which will contain one of the one of the text from LIST_KEY . I would like to get corresponding Category list from LIST_CAT depends upon the Key value

I am using below VBA code to achieve this. This include a Array formula.

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

This code works perfect if there is less data to fetch. But in my original use case, I will have around 8000 rows. Due to this large number of columns excel will go to not responding state after 2-3 minutes.

Instead of adding Array formula to column B, Is there anyway to convert that into VBA to run this faster. Sorry, I am new to this VBA stuff and dont have much experience

Answer 1

Try the following code, which uses arrays instead of worksheet formulas...

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