Производительность в формуле соответствия в For Loop

Question

Следующий код работает, но я пытаюсь найти более эффективный способ сделать то же самое, потому что это занимает вечность.У меня около 30 кусков кода, выполняющих одно и то же, и в общей сложности это занимает 3-4 часа.

Начало кода простое и не проблема.Для столбца M он соответствует идентификатору продукта (RC [-12]) и коду активности (R4C2) на другом листе (DeSL_CP_Table) и возвращает базовую дату окончания.То же самое для столбца N, но с возвратом даты завершения.Код активности в R4C2 - это код, предназначенный только для лицензионных продуктов.

Мне нужно сделать то же самое для нелицензионного продукта, но я не могу использовать автозаполнение, потому что я не хочу перезаписывать лицензионные данные.выше.Колонка АК сообщает мне, является ли продукт лицензированным или нелицензированным.Код активности в R5C2 предназначен для нелицензионного продукта.Оператор if без цикла for не страшен, если его запустить один раз, но я делаю это для многих других столбцов, ищущих другие подобные вещи в моем отчете.Любая помощь по более быстрому способу запустить это было бы здорово.

Sheets("Summary").Select
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row

'Licensed
Range("M7").Select
Selection.FormulaArray = _
    "=INDEX(DeSL_CP_Table[BaseLineEnd],MATCH(RC[-12]&R4C2,DeSL_CP_Table[ProductID]&DeSL_CP_Table[ActivityCode],0))"
Range("N7").Select
Selection.FormulaArray = _
    "=INDEX(DeSL_CP_Table[CompletionDate],MATCH(RC[-13]&R4C2,DeSL_CP_Table[ProductID]&DeSL_CP_Table[ActivityCode],0))"
Selection.AutoFill Destination:=Range("M7:n" & lastRow), Type:=xlFillDefault

On Error Resume Next
Cells.SpecialCells(xlCellTypeFormulas, xlErrors).ClearContents ' Delete #N/A
On Error GoTo 0

'Unlicensed
Dim strVal As String
Dim ranA As Range

For Each ranA In Range("AK2:AK" & lastRow) ' look through unlicensed
    strVal = ranA
    'MsgBox (strVal)
    If strVal = "Unlicensed" Then
        ranA.Offset(0, -24).FormulaArray = _
         "=INDEX(DeSL_CP_Table[BaseLineEnd],MATCH(RC[-12]&R5C2,DeSL_CP_Table[ProductID]&DeSL_CP_Table[ActivityCode],0))"
        ranA.Offset(0, -23).FormulaArray = _
         "=INDEX(DeSL_CP_Table[CompletionDate],MATCH(RC[-13]&R5C2,DeSL_CP_Table[ProductID]&DeSL_CP_Table[ActivityCode],0))"
    End If
 Next ranA

Я пробовал массивы, но на самом деле это занимает больше времени.Это кусок для нелицензионного.

Dim lastRow1 As Long
lastRow1 = Sheets("DeSL_CP").Range("A" & Rows.Count).End(xlUp).Row

Dim BaselineEnd As Variant, ActivityCode As Variant, ProductID As Variant
BaselineEnd = ThisWorkbook.Worksheets("DeSL_CP").Range("P2:P" & lastRow1).Value
ActivityCode = ThisWorkbook.Worksheets("DeSL_CP").Range("K2:K" & lastRow1).Value
ProductID = ThisWorkbook.Worksheets("DeSL_CP").Range("B2:B" & lastRow1).Value

Dim resultArray() As String
ReDim resultArray(7 To lastRow)
Dim i As Long, j As Long

With ThisWorkbook.Worksheets("Summary")
For i = 7 To lastRow
    resultArray(i) = ""
    For j = 1 To UBound(ActivityCode)
    If .Range("AK" & i).Value = "Unlicensed" Then
        If ActivityCode(j, 1) = "AA0001" Then
            If .Range("A" & i).Value = ProductID(j, 1) Then
                    resultArray(i) = BaselineEnd
                    Exit For
            End If
        End If
    End If
    Next j
Next i

.Range("M7").Resize(lastRow - 3 + 1, 1).Value = resultArray
End With

Answer 1

Я наконец-то понял, как исправить массивы - см. Пост «Справка по массивам VBA - ошибок нет, но не возвращает правильных данных» - есть три различных способа решения этой проблемы со временем, затрачиваемым каждой из них. Этот занимает менее 10 секунд, по сравнению с 3-5 минутами для двух других.

Option Base 1

Sub FillInConcept()

Sheets("Summary").Select
Dim lastRow As Long, lastRow1 As Long
lastRow = Sheets("Summary").Range("A" & Rows.Count).End(xlUp).Row
lastRow1 = Sheets("DeSL_CP").Range("B" & Rows.Count).End(xlUp).Row
lastRow1 = lastRow1 - 1


Dim BaselineEnd As Variant, ActivityCode As Variant, ProductIDDeSL As Variant, 
Licensed As Variant, ProductIDSumm As Variant
BaselineEnd = ThisWorkbook.Worksheets("DeSL_CP").Range("P2:P" & lastRow1).Value
ActivityCode = ThisWorkbook.Worksheets("DeSL_CP").Range("K2:K" & lastRow1).Value
ProductIDDeSL = ThisWorkbook.Worksheets("DeSL_CP").Range("B2:B" & lastRow1).Value
Licensed = ThisWorkbook.Worksheets("Summary").Range("AK7:AK" & lastRow).Value
ProductIDSumm = ThisWorkbook.Worksheets("Summary").Range("A7:A" & lastRow).Value

Dim resultArray() As Date
ReDim resultArray(lastRow - 7 + 1, 1)
Dim i As Long, j As Long
With ThisWorkbook.Worksheets("Summary")
For i = 1 To UBound(ProductIDSumm)
For j = 1 To UBound(ProductIDDeSL)
'If Not Sheets("DeSL_CP").Rows(j).Hidden Then
If ProductIDSumm(i, 1) = ProductIDDeSL(j, 1) Then
    If Licensed(i, 1) = "Unlicensed" Then
        If ActivityCode(j, 1) = "AA0001" Then
        resultArray(i, 1) = BaselineEnd(j, 1)
        Exit For
        End If
    Else
        If ActivityCode(j, 1) = "A0003" Then
        resultArray(i, 1) = BaselineEnd(j, 1)
        Exit For
        End If
    End If
End If
'End If
Next j
Next i

WorksheetFunction.Transpose (resultArray)
Range("M7").Resize(UBound(resultArray), 1).Value = resultArray
End With
End Sub