Преобразование формулы массива Excel в код VBA

Question

У меня есть два набора диапазонов с именами LIST_KEY и LIST_CAT. В столбце A пользователь добавит некоторые данные, которые будут содержать один из текста из LIST_KEY. Я хотел бы получить соответствующий список категорий из LIST_CAT в зависимости от значения ключа

Я использую приведенный ниже код VBA для достижения этой цели. Это включает формулу Array.

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 будет go не отвечать на запросы через 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