Долгая работа макроса, который сравнивает данные из двух листов

Question

Ищу в мэппинговой таблице и расставляю на основной что нашёл в мэппинге и что не нашёл:

Sub CheckCCRCompleteness()
    '1. Создаёт ключ в колонке №44 (закладка "Data"): №4 & №6 & №12 в требуемом отчётном месяце'
    '2. Смотрит есть ли созданный на шаге №1 ключ в массиве ключей на закладке "Completeness CCR" в соответствующем отчётном месяце (месяц определяется как первое число каждого отчётного месяца)'
    '3. Если ключ с шага №1 не найден на шаге №2, то в колонке №44 (закладка "Data") ставит признак "Нет на CCR" (если обнаружил, то ставит признак "ОК")'
    'Примечание: изначально в колонке №44 (закладка "Data") сделал формулу для проверки, но тогда файл долго пересчитывается (поэтому было решено сделать кнопку, которая будет для каждого отчётного месяца создавать ключи (в колонке №44 (закладка "Data")) и проверять его наличие на закладке "Completeness CCR"'

        Dim SourceData As Worksheet: Set SourceData = ThisWorkbook.Sheets("Data") 'Определяем закладку-источник данных'
        Dim Mapping As Worksheet: Set Mapping = ThisWorkbook.Sheets("Completess CCR") 'Определяем источник мэппинга'

        Dim SourceDataLstr As Long, MappingLstr As Long
        Dim i As Long, j As Long
        Dim RawDataKey As String, MappingKey As String
        Dim ReportMonth As Date
        Dim ReportMonthCol As Long
        Dim Rng As Range

        SourceDataLstr = SourceData.Range("A" & Rows.Count).End(xlUp).Row 'Находим последнюю строку на закладке-источнике'
        MappingLstr = Mapping.Range("A" & Rows.Count).End(xlUp).Row 'Находим последнюю строку на источнике мэппинга'

        ReportMonth = InputBox("Введите первую дату отчётного месяца (например, 01.12.2019)") 'Задаём отчётный месяц, в котором генерируем ключ'

        'Определяем номер столбца на закладке "Completeness CCR", в котором содержатся ключи требуемого отчётного месяца'
        Set Rng = Sheets("Completess CCR").Rows(1).Find(ReportMonth, , xlFormulas, xlWhole)
        ReportMonthCol = Rng.Column
        'Debug.Print ReportMonthCol'

        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual

        With SourceData
            For i = 2 To SourceDataLstr
                If Cells(i, 12).Value = ReportMonth Then
                    RawDataKey = .Cells(i, 4).Value & .Cells(i, 6).Value & .Cells(i, 12).Value
                    For j = 2 To MappingLstr
                        MappingKey = Mapping.Cells(j, ReportMonthCol).Value
                        If MappingKey <> RawDataKey Then
                            .Cells(i, 44).Value = "Нет на CCR"
                        Else: .Cells(i, 44).Value = "OK"
                            Exit For
                        End If
                    Next j
                Else
                End If
            Next i
        End With

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Уходит в небытие... где-то здесь:

If MappingKey <> RawDataKey Then
   .Cells(i, 44).Value = "Нет на CCR"
Else: .Cells(i, 44).Value = "OK"
Exit For

Answer 1

Уходим от медленной работы с объектами листа. По одному разу обращаемся к листам для получения данных и еще раз - выгружаем результат.

Sub CheckCCRCompleteness()
    Dim aData(), aMapp(), aResult()
    Dim ReportMonthCol As Long, ReportMonth
    Dim bFlag As Boolean
    Dim RawDataKey As String
    Dim i As Long, n As Long

    Call Extraction_(aMapp, Worksheets("Completess CCR"))
    Call Extraction_(aData, Worksheets("Data"))

    ReDim aResult(1 To UBound(aData), 1 To 1)
    aResult(1, 1) = Worksheets("Data").Cells(1, 44).Value

    ReportMonth = Val(InputBox("Введите номер отчетного месяца (от 1 до 12)"))

    If ReportMonth < 1 Or ReportMonth > 12 Then
        MsgBox "Неправильно указан месяц", 64, "ОШИБКА": Exit Sub
    Else
        ReportMonth = DateSerial(Year(Date), ReportMonth, 1)
    End If

    ReportMonthCol = fFindMonth(aMapp, ReportMonth)
    If ReportMonthCol = 0 Then Exit Sub

    For i = 2 To UBound(aData)
        If aData(i, 12) = ReportMonth Then
            RawDataKey = aData(i, 4) & aData(i, 6) & CDbl(aData(i, 12))

            For n = 2 To UBound(aMapp)
                If aMapp(n, ReportMonthCol) = RawDataKey Then
                    aResult(i, 1) = "OK"
                    bFlag = True: Exit For
                End If
            Next n

            If bFlag = False Then aResult(i, 1) = "Нет на CCR" Else bFlag = False
        End If
    Next i

    Worksheets("Data").Cells(1, 44).Resize(UBound(aData), 1).Value = aResult
End Sub

Sub Extraction_(aArr(), sht As Worksheet)
    Dim lLastRow As Long

    With sht
        lLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
        If lLastRow < 2 Then End
        aArr = .Range("A1:L" & lLastRow).Value
    End With
End Sub

Function fFindMonth(aMapp(), ReportMonth) As Long
    Dim j As Long

    For j = 4 To UBound(aMapp, 2)
        If aMapp(1, j) = ReportMonth Then
            fFindMonth = j: Exit Function
        End If
    Next j
End Function

Если нужно, добавьте отключение/включение обновления экрана и пересчетов.

БЛОГ НА HUSL

Долгая работа макроса, который сравнивает данные из двух листов

Ответы (1 шт):