由于大小

Question

我在VBA中创建了一个脚本，它应该在“数据”表中读取一个包含超过190,000个条目的非常长的数据透视表，并且根据“J”列中的值，它应该从该行中写入信息。表格称为“温度”。 当列“A”的值发生更改时，它应从工作表“Regioner”读取超过600个条目的列表，并检查每个值是否显示在先前的值数组中。 我写的代码有效，但在“Temp”表中记下预期的220,000个条目需要永远。在我的笔记本电脑中，i5第6代配备8Gb RAM，它只是崩溃了。 目前的代码如下。 非常感谢所有人！

Public Sub FindWithoutOrder()

Dim DataRowCounter As Long
Dim TempRowCounter As Long
Dim RegiRowCounter As Long
Dim DataOldCounter As Long
Dim DataNewCounter As Long
Dim loopCounter As Long
Dim DataOldProd As Range
Dim DataNewProd As Range
Dim DataPurchase As Range
Dim RegiButikk As Range
Dim ButikkFlag As Boolean

'Code optimization to run faster.
Application.ScreenUpdating = False
Application.DisplayAlerts = False

'Initialize variables.
'----------------------------------------------------------------------------------------------------------
DataRowCounter = 11
TempRowCounter = 1
DataOldCounter = 11
DataNewCounter = 11
Set DataOldProd = ActiveWorkbook.Sheets("Data").Range("A" & DataRowCounter)
Set DataNewProd = ActiveWorkbook.Sheets("Data").Range("A" & DataRowCounter)
Set DataPurchase = ActiveWorkbook.Sheets("Data").Range("J" & DataRowCounter)

'Start of loop that verifies all values inside "Data" sheet.
'----------------------------------------------------------------------------------------------------------
Do Until (IsEmpty(DataOldProd) And IsEmpty(DataNewProd))

    'Verify if the product of new line is still the same or different.
    '------------------------------------------------------------------------------------------------------
    If DataNewProd.Value = DataOldProd.Value Then
        DataNewCounter = DataNewCounter + 1
    Else

        'Initialize variables from "Regioner" sheet.
        '------------------------------------------------------------------------------------------
        ButikkFlag = False
        RegiRowCounter = 11
        Set RegiButikk = ActiveWorkbook.Sheets("Regioner").Range("C" & RegiRowCounter)

        'Verify list of supermarkets and match them with purchases list.
        '--------------------------------------------------------------------------------------------------
        Do Until IsEmpty(RegiButikk)

            'Check all supermarkets in the product range.
            '----------------------------------------------------------------------------------------------
            For loopCounter = DataOldCounter To DataNewCounter - 1

                'Compare both entries and register them if it doesn't exist in the product list.
                '------------------------------------------------------------------------------------------
                If RegiButikk.Value = ActiveWorkbook.Sheets("Data").Range("D" & loopCounter).Value Then
                    ButikkFlag = True
                    RegiRowCounter = RegiRowCounter + 1
                    Set RegiButikk = ActiveWorkbook.Sheets("Regioner").Range("C" & RegiRowCounter)
                    Exit For
                Else
                    ButikkFlag = False
                End If

            Next loopCounter

            'Add to list supermarkets not present in the purchases list.
            '------------------------------------------------------------------------------------------
            If ButikkFlag = False Then
                ActiveWorkbook.Sheets("Temp").Range("B" & TempRowCounter & ":D" & TempRowCounter).Value = ActiveWorkbook.Sheets("Regioner").Range("A" & RegiRowCounter & ":C" & RegiRowCounter).Value
                ActiveWorkbook.Sheets("Temp").Range("A" & TempRowCounter).Value = ActiveWorkbook.Sheets("Data").Range("A" & DataRowCounter - 1).Value
                TempRowCounter = TempRowCounter + 1
                RegiRowCounter = RegiRowCounter + 1
                Set RegiButikk = ActiveWorkbook.Sheets("Regioner").Range("C" & RegiRowCounter)
            End If

        Loop

        'Reset the product range.
        '--------------------------------------------------------------------------------------------------
        DataOldCounter = DataNewCounter
        DataNewCounter = DataNewCounter + 1

    End If

    'Validate if item was purchased in the defined period and copy it.
    '------------------------------------------------------------------------------------------------------
    If DataPurchase.Value = 0 Then
        ActiveWorkbook.Sheets("Temp").Range("A" & TempRowCounter & ":D" & TempRowCounter).Value = ActiveWorkbook.Sheets("Data").Range("A" & DataRowCounter & ":D" & DataRowCounter).Value
        TempRowCounter = TempRowCounter + 1
    End If

    'Update row counter and values for previous and new product readed.
    '------------------------------------------------------------------------------------------------------
    Set DataOldProd = ActiveWorkbook.Sheets("Data").Range("A" & DataRowCounter)
    DataRowCounter = DataRowCounter + 1
    Set DataNewProd = ActiveWorkbook.Sheets("Data").Range("A" & DataRowCounter)
    Set DataPurchase = ActiveWorkbook.Sheets("Data").Range("J" & DataRowCounter)

Loop

'Code optimization to run faster.
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

Answer 1

而不是将这些代码分散到各处：

'Code optimization to run faster.
Application.ScreenUpdating = False
Application.DisplayAlerts = False

使用此程序：

Public Sub ToggleWaitMode(ByVal wait As Boolean)
    Application.Cursor = IIf(wait, XlMousePointer.xlWait, XlMousePointer.xlDefault)
    Application.StatusBar = IIf(wait, "Working...", False)
    Application.Calculation = IIf(wait, XlCalculation.xlCalculationManual, XlCalculation.xlCalculationAutomatic)
    Application.ScreenUpdating = Not wait
    Application.EnableEvents = Not wait
End Sub

像这样：

Public Sub DoSomething()
    ToggleWaitMode True 
    On Error GoTo CleanFail

    'do stuff

CleanExit:
    ToggleWaitMode False
    Exit Sub
CleanFail:
    'handle errors
    Resume CleanExit
End Sub

禁用自动计算和工作表事件应该已经有很多帮助...但它绝不是＆＃34;优化＆＃34;任何东西。无论何时修改单元格，它都会使Excel工作得更少。

如果您的代码有效，但速度很慢，请将其带到Code Review Stack Exchange，然后将其呈现给VBA审核者：他们会尽力帮助您实际上优化您的代码。我知道，我其中一个=）