Предложения по ускорению / улучшению этого сценария VBA? - PullRequest
1 голос
/ 21 апреля 2020

Есть предложения или советы, чтобы сделать это лучше? Я использовал его для небольших наборов данных (100-1000 строк), и он отлично работает. Попытка запустить его на наборе данных, содержащем около 100 000 строк, приводит к тому, что во время работы он не отвечает, и мне приходится принудительно выходить из Excel.

    Sub CombineSchARecords()

        Dim myRow As Long

    'Row data starts
        myRow = 2

        Application.ScreenUpdating = False

    'Loop until out of data
        Do Until Cells(myRow, "A") = ""

    'Check to see if next row is for same filing number
        If Cells(myRow, "A") = Cells(myRow + 1, "A") Then

    'Add data to correct column
        Cells(myRow, "B") = Cells(myRow, "B") & ", " & Cells(myRow + 1, "B") 'SchA-3
        Cells(myRow, "C") = Cells(myRow, "C") & ", " & Cells(myRow + 1, "C") 'Schedule
        Cells(myRow, "D") = Cells(myRow, "D") & " | " & Cells(myRow + 1, "D") 'Full Legal Name
        Cells(myRow, "E") = Cells(myRow, "E") & ", " & Cells(myRow + 1, "E") 'DE/FE/I
        Cells(myRow, "F") = Cells(myRow, "F") & ", " & Cells(myRow + 1, "F") 'Entity in Which
        Cells(myRow, "G") = Cells(myRow, "G") & ", " & Cells(myRow + 1, "G") 'Title or Status
        Cells(myRow, "H") = Cells(myRow, "H") & ", " & Cells(myRow + 1, "H") 'Status Aquired
        Cells(myRow, "I") = Cells(myRow, "I") & ", " & Cells(myRow + 1, "I") 'Ownership Code
        Cells(myRow, "J") = Cells(myRow, "J") & ", " & Cells(myRow + 1, "J") 'Control Person
        Cells(myRow, "K") = Cells(myRow, "K") & ", " & Cells(myRow + 1, "K") 'PR
        Cells(myRow, "L") = Cells(myRow, "L") & ", " & Cells(myRow + 1, "L") 'OwnerID

    'Then delete row
        Rows(myRow + 1).Delete
            Else
        myRow = myRow + 1 'Move down one row if no match

            End If

Loop

Application.ScreenUpdating = True

End Sub

Спасибо!

Ответы [ 2 ]

1 голос
/ 21 апреля 2020

Стандартный способ добиться хорошего ускорения состоит в том, чтобы одним оператором прочитать все в один большой массив VBA, обработать этот массив в VBA и затем поместить результат обратно в электронную таблицу в другом операторе. Две строки кода, которые касаются электронной таблицы, а не более 100 000+ операций чтения / записи электронных таблиц на всех oop

С точки зрения вашей проблемы это будет означать что-то вроде:

Sub CombineSchARecords()
    Dim n As Long, i As Long, j As Long
    Dim numRecords As Long
    Dim Values As Variant, Processed As Variant

    n = Cells(Rows.Count, 1).End(xlUp).Row
    Values = Range(Cells(2, "A"), Cells(n, "K")).Value
    ReDim Processed(1 To n - 1, 1 To 11)

    'initialize first row of Processed
    For j = 1 To 11
        Processed(1, j) = Values(1, j)
    Next j
    numRecords = 1

    'main loop

    For i = 2 To n - 1
        If Values(i, 1) = Processed(numRecords, 1) Then
            For j = 2 To 11
                Processed(numRecords, j) = Processed(numRecords, j) & IIf(j = 4, " | ", ", ") & Values(i, j)
            Next j
        Else 'start processing a new record
            numRecords = numRecords + 1
            For j = 1 To 11
                Processed(numRecords, j) = Values(i, j)
            Next j
        End If
    Next i

    'redim Values and copy records over

    ReDim Values(1 To numRecords, 1 To 11)
    For i = 1 To numRecords
        For j = 1 To 11
            Values(i, j) = Processed(i, j)
        Next j
    Next i

    'finally:
    Range(Cells(2, "A"), Cells(n, "K")).ClearContents
    Range(Cells(2, "A"), Cells(numRecords + 1, "K")).Value = Values

End Sub
0 голосов
/ 21 апреля 2020

Помимо использования массива VBA для определения вашей переменной, вы также можете использовать приведенный ниже код для ускорения вашего сценария.

Application.Calculation = xlManual
'Your code between this
Application.Calculation = xlAutomatic
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...