Question

我想知道是否有人可以就我编译的以下循环代码提供建议。当我从笔记本电脑上运行它时，它会在2-3秒内快速处理，但是我在一台工作计算机上运行它并且运行速度非常慢，需要10多分钟才能完成3000-4000行。

    Dim LastRow As Long
    Dim Cell, Rng, Table As Range

    'Turn off Screen updating - Speed process - Turn back on prior to Exit Sub
    Application.ScreenUpdating = False

    Sheets("Del Data").Select

    'Validate Data Exists in Range
    If Range("B3").Value = "" Then
        MsgBox "No Data Available to calculate." & vbNewLine & _
        "Please ensure first consigment number is pasted in cell B3." & vbNewLine & vbNewLine & _
        "For assistance please refer to user manual supplied with file.", _
        vbCritical, "Error Compiling Stop Calculator"
        Application.ScreenUpdating = True
        Exit Sub
    End If

    'Identify Last possible row and set Range
    With ActiveSheet
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With

    Set Rng = Range("B3:B" & LastRow)

    '**********************************
    ' Calculate unique values  
    '**********************************
    For Each Cell In Rng
        Cell.Offset(0, 33).Value = Trim(Left(Cell.Offset(0, 5).Value, 3))
        Cell.Offset(0, 34).Value = Trim(Left(Cell.Offset(0, 7).Value, 3))
        Cell.Offset(0, 35).Value = Trim(Left(Cell.Offset(0, 17).Value, 3))
        Cell.Offset(0, 38).Value = Trim(Cell.Offset(0, 21).Value)

        Cell.Offset(0, 36).Value = Cell.Offset(0, 34).Value & Cell.Offset(0, 33).Value & Cell.Offset(0, 38).Value
        Cell.Offset(0, 37).Value = Cell.Offset(0, 34).Value & Cell.Offset(0, 34).Value & Cell.Offset(0, 38).Value
    Next 
    Application.ScreenUpdating = True
Exit Sub

有没有办法改进上面的代码以加快速度？据我所知，因为我的笔记本电脑上的运行正常，所以我的工作PC可能只是计算机问题，尽管PC的规格确实很好，绝对可以完成任务。

Answer 1

Dim i As Long

'**********************************
' Calculate unique values
'**********************************
With ActiveSheet
    For i = 3 To LastRow
        .Cells(i, 35).Value = Trim$(Left$(.Cells(i, 7).Value, 3))
        .Cells(i, 36).Value = Trim$(Left$(.Cells(i, 9).Value, 3))
        .Cells(i, 37).Value = Trim$(Left$(.Cells(i, 19).Value, 3))
        .Cells(i, 40).Value = Trim$(Left$(.Cells(i, 23).Value, 3))

        .Cells(i, 38).Value = .Cells(i, 36).Value & .Cells(i, 35).Value & .Cells(i, 40).Value
        .Cells(i, 39).Value = .Cells(i, 36).Value & .Cells(i, 36).Value & .Cells(i, 40).Value
    Next i
End With

Answer 2

我使用VBA数组来加快速度，并且可以在这里和那里进行一些调整。

我没有测试代码，所以请先复制一份数据。

Option Explicit

Sub Test()


'Sheets("Del Data").Select
With thisworkbook.Sheets("Del Data")

    'Validate Data Exists in Range
    If .Range("B3").Value = vbNullString Then
        MsgBox "No Data Available to calculate." & vbNewLine & _
        "Please ensure first consigment number is pasted in cell B3." & vbNewLine & vbNewLine & _
        "For assistance please refer to user manual supplied with file.", _
        vbCritical, "Error Compiling Stop Calculator."
        Exit Sub
    End If


    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With

    'i declared the variables after the condition to exit sub
    Dim LastRow As Long, i&
    Dim Rng As Range
    Dim RngArray() 'is a variant type array, used to fast up the process

    'Identify Last possible row and set Range
    LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row

    Set Rng = .Range(.Cells(3, 2), .Cells(LastRow, 2)) '"B3:B" & LastRow)

    RngArray = .Range(.Cells(1, 2), .Cells(LastRow, 2 + 39)).Value2


    '**********************************
    ' Calculate unique values
    'beware: Cell.Offset(0, 0) is converted in my coding to RngArray(i, 1)
    '**********************************

    For i = 3 To LastRow

        'Cell.Offset(0, 33).Value = Trim(Left(Cell.Offset(0, 5).Value, 3))
        RngArray(i, 34) = Left(Trim(RngArray(i, 6)), 3)

        'Cell.Offset(0, 34).Value = Trim(Left(Cell.Offset(0, 7).Value, 3))
        RngArray(i, 35) = Left(Trim(RngArray(i, 8)), 3)

        'Cell.Offset(0, 35).Value = Trim(Left(Cell.Offset(0, 17).Value, 3))
        RngArray(i, 36) = Left(Trim(RngArray(i, 18)), 3)

        'Cell.Offset(0, 38).Value = Trim(Cell.Offset(0, 21).Value)
        RngArray(i, 39) = Left(Trim(RngArray(i, 22)))

        'Cell.Offset(0, 36).Value = Cell.Offset(0, 34).Value & Cell.Offset(0, 33).Value & Cell.Offset(0, 38).Value
        RngArray(i, 37) = RngArray(i, 35) + RngArray(i, 34) + RngArray(i, 39)

        'Cell.Offset(0, 37).Value = Cell.Offset(0, 34).Value & Cell.Offset(0, 34).Value & Cell.Offset(0, 38).Value
        RngArray(i, 38) = 2 * RngArray(i, 35) + RngArray(i, 39) 'OP readed twice same Cell , i used *2, might be OP miss

    Next i

    'write back values to sheet
    .Range(.Cells(1, 2), .Cells(LastRow, 2 + 39)).Value2 = RngArray

End With


Set Rng = Nothing
Erase RngArray

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = xlAutomatic
End With
Exit Sub

循环函数优化 - 目前运行缓慢

2 个答案: