Question

我对VBA /宏非常陌生，试图弄清楚如何提高运行模拟的速度。我的代码包括从工作表中的一个单元格复制日期，将日期粘贴到另一工作表中，并循环遍历多次。任何帮助将不胜感激。

Sub Run_Sim()

' Run_Sim Macro

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Sheets("Runs").Select
Range("A2:C100005").ClearContents

Dim i As Integer

For i = 2 To 5001
    ' Calculate
    Sheets("Calc").Select
    Range("O3").Select
    Selection.Copy
    Sheets("Runs").Select
    Cells(i, 2).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    'If Cells(i, 2).Value = 0 Then
        ' Cells(i, 2).Font.Color = vbRed
     '   Sheets("Calc").Select
     '   Range("O3").Select
     '   Selection.Copy
     '   Sheets("Runs").Select
     '   Cells(i, 2).Select
     '   Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
     '       :=False, Transpose:=False
    'End If
    Cells(i, 1).Value = i - 1
    If Cells(i, 2).Value = 0 Then
        Cells(i, 3).Value = 0
    Else
        Cells(i, 3).Value = 1
    End If
    Calculate
Next i

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub

理想情况下，希望增加仿真数量，但是完成此过程所需的时间是一个很大的限制因素。

Answer 1

谈到速度，我发现您的代码存在三个主要问题

请勿使用.Select
使用值转移（Range.Value = Range.Value）代替Copy/Paste
将代码范围限制为相关范围。如果仅使用1,000行，为什么要循环5,001行？

Option Explicit

Sub Run_Sim()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Runs")
Dim cs As Worksheet: Set cs = ThisWorkbook.Sheets("Calc")
Dim LR As Long, i As Long

LR = ws.Range("B" & ws.Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False
  ws.Range("A2:C" & LR).ClearContents
    For i = 2 To LR

        ws.Range("B" & i).Value = cs.Range("O3").Value
        ws.Range("A" & i) = i - 1

        If ws.Range("B" & i) = 0 Then
            ws.Range("C" & i) = 0
        Else
            ws.Range("C" & i) = 1
        End If

    Next i
Application.ScreenUpdating = True

End Sub

此外，由于您将Column B中的每一行都设置为等于一个值，因此您可以在循环外的第一行中执行此操作。注意上面和下面的代码之间的细微差别。减少了循环内部的操作，这将提高效率。

Option Explicit

Sub Run_Sim()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Runs")
Dim cs As Worksheet: Set cs = ThisWorkbook.Sheets("Calc")
Dim LR As Long, i As Long, CalcDate As Date

LR = ws.Range("A" & ws.Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False
  ws.Range("A2:C" & LR).ClearContents
  ws.Range("B2:B" & i) = CalcDate '<-- Date transfer all at once

    For i = 2 To LR

        If ws.Range("B" & i) = 0 Then
            ws.Range("C" & i) = 0
        Else
            ws.Range("C" & i) = 1
        End If

    Next i

Application.ScreenUpdating = True

End Sub

在这里我将不演示的另一个选项是遍历一个范围（For Each Cell in Range），而不是使用一个可变范围（For i = 2 to LR）。这些循环往往会更快。

如何修复极慢的复制粘贴Excel VBA代码？

1 个答案: