Excel 如何加快将值从一张图纸复制到另一张图纸？

我想从工作表中复制值，以使用该工作表计算结果

有很多来回。有没有办法加快速度

我尝试了其他一些优化方法，但我希望它能运行得更快

Sub design()

Dim MFrow As Integer

Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
Application.Calculation = xlAutomatic

MFrow = 4

Do Until MFrow = 208
    'Application.Calculation = xlManual
            
    'from Summary to Design
    Worksheets("Frame Beam Summary").Range("I" & MFrow & ":" & "M" & MFrow).Copy
    Worksheets("Frame Beam Design").Range("O11").PasteSpecial Paste:=xlPasteValues, Transpose:=True
            
    Worksheets("Frame Beam Summary").Range("P" & MFrow & ":" & "T" & MFrow).Copy
    Worksheets("Frame Beam Design").Range("P11").PasteSpecial Paste:=xlPasteValues, Transpose:=True
    
    'from Summary to Design
    Worksheets("Frame Beam Design").Range("R35:T35").Value = Worksheets("Frame Beam Summary").Range("W" & MFrow & ":" & "y" & MFrow).Value
    Worksheets("Frame Beam Design").Range("R36:T36").Value = Worksheets("Frame Beam Summary").Range("AB" & MFrow & ":" & "AD" & MFrow).Value
    Worksheets("Frame Beam Design").Range("R37:T37").Value = Worksheets("Frame Beam Summary").Range("AG" & MFrow & ":" & "AI" & MFrow).Value
            
    'Application.Calculation = xlAutomatic
    
    'from Design to Summary
    Range("ETABS_U").Value = Worksheets("Frame Beam Summary").Range("C" & MFrow)
    Worksheets("Frame Beam Summary").Range("D" & MFrow).Value = Range("End1Mu").Value
    Worksheets("Frame Beam Summary").Range("E" & MFrow).Value = Range("MidMu").Value
    Worksheets("Frame Beam Summary").Range("F" & MFrow).Value = Range("End2Mu").Value
    Worksheets("Frame Beam Summary").Range("G" & MFrow).Value = Worksheets("Frame Beam Design").Range("F24")
    Worksheets("Frame Beam Summary").Range("H" & MFrow).Value = Worksheets("Frame Beam Design").Range("H23")
    
    'from Design to Summary
    Worksheets("Frame Beam Design").Range("O28:O29").Copy
    Worksheets("Frame Beam Summary").Range("N" & MFrow).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    Worksheets("Frame Beam Design").Range("P28:P29").Copy
    Worksheets("Frame Beam Summary").Range("U" & MFrow).PasteSpecial Paste:=xlPasteValues, Transpose:=True
    
    'from Design to Summary
    Worksheets("Frame Beam Summary").Range("Z" & MFrow & ":" & "AA" & MFrow).Value = Worksheets("Frame Beam Design").Range("Y35:Z35").Value
    Worksheets("Frame Beam Summary").Range("AE" & MFrow & ":" & "AF" & MFrow).Value = Worksheets("Frame Beam Design").Range("Y36:Z36").Value
    Worksheets("Frame Beam Summary").Range("AJ" & MFrow & ":" & "AK" & MFrow).Value = Worksheets("Frame Beam Design").Range("Y37:Z37").Value

    MFrow = MFrow + 1
Loop

Application.ScreenUpdating = True
End Sub

带重新计算的循环

• 如果不知道单元格中的确切公式，很难说，但这可能有用
• 玩

  Calculation

  ，可能在第一次运行时对其进行注释，以查看效率是否有任何差异（也可以对其进行注释

  Application.Calculation=xlCalculationManual

  ）。使用常识来计算出在哪一点应该计算什么。我只是猜测一下。解决方案可能完全不同
• 这很少以这种方式完成，因此请考虑在不依赖循环中的公式的情况下重写整个过程，即VBA可以完成公式正在执行的操作，并且可能需要一秒钟左右的时间才能完成。当然，如果看不到整个设置，就无法确定

代码

Option Explicit

Sub design()
    
    Const ProcName As String = "design"
    ' If you start getting error messages in the Immediate window,
    ' then out-comment the following line to see where the error is occurring.
    ' When the problem is solved, uncomment the line.
    On Error GoTo clearError

    Const MFrow As Long = 4
    Const LFrow As Long = 207
     
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = False
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.Calculation = xlCalculationManual
    
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim smr As Worksheet
    Set smr = wb.Worksheets("Frame Beam Summary")
    Dim des As Worksheet
    Set des = wb.Worksheets("Frame Beam Design")
    
    ' 5 cells
    Dim s1 As Range: Set s1 = smr.Columns("I:M")
    Dim d1 As Range: Set d1 = des.Range("O11").Resize(s1.Columns.Count)
    Dim s2 As Range: Set s2 = smr.Columns("P:T")
    Dim d2 As Range: Set d2 = des.Range("P11").Resize(s2.Columns.Count)
    ' 3 cells
    Dim s3_1 As Range: Set s3_1 = smr.Columns("W:Y")
    Dim s3_2 As Range: Set s3_2 = smr.Columns("AB:AD")
    Dim s3_3 As Range: Set s3_3 = smr.Columns("AG:AI")
    Dim d3 As Range: Set d3 = des.Range("R35:T37")
    ' 1 cell
    Dim s4 As Range: Set s4 = smr.Columns("C:H")
    ' 2 cells
    Dim s5 As Range: Set s5 = smr.Columns("N:O")
    Dim d5 As Range: Set d5 = des.Range("O28").Resize(s1.Columns.Count)
    Dim s6 As Range: Set s6 = smr.Columns("U:V")
    Dim d6 As Range: Set d6 = des.Range("P28").Resize(s1.Columns.Count)
    ' 2 cells
    Dim s7_1 As Range: Set s7_1 = smr.Columns("Z:AA")
    Dim s7_2 As Range: Set s7_2 = smr.Columns("AE:AF")
    Dim s7_3 As Range: Set s7_3 = smr.Columns("AJ:AK")
    Dim d7 As Range: Set d7 = des.Range("Y35:Z37")
    
    Dim i As Long
    For i = MFrow To LFrow
        
        'from Summary to Design
        d1.Value = Application.Transpose(s1.Rows(i).Value)
        d2.Value = Application.Transpose(s2.Rows(i).Value)
        d3.Rows(1).Value = s3_1.Rows(i).Value
        d3.Rows(2).Value = s3_2.Rows(i).Value
        d3.Rows(3).Value = s3_3.Rows(i).Value
        
        ' Maybe
        des.Calculate
        ' Or just:
'        Application.Calculation = xlAutomatic
'        DoEvents
'        Application.Calculation = xlCalculationManual
       
        'from Design to Summary
        Range("ETABS_U").Value = s4.Cells(i, 1).Value
        s4.Cells(i, 2).Value = Range("End1Mu").Value
        s4.Cells(i, 3).Value = Range("MidMu").Value
        s4.Cells(i, 4).Value = Range("End2Mu").Value
        s4.Cells(i, 5).Value = des.Range("F24").Value
        s4.Cells(i, 6).Value = des.Range("H23").Value
       
        'from Design to Summary
        s5.Rows(i).Value = Application.Transpose(d5.Value)
        s6.Rows(i).Value = Application.Transpose(d6.Value)
        
        'from Design to Summary
        s3_1.Rows(i).Value = d3.Rows(1).Value
        s3_2.Rows(i).Value = d3.Rows(2).Value
        s3_3.Rows(i).Value = d3.Rows(3).Value

        ' Maybe
        smr.Calculate
        
    Next i

ProcExit:
    
    Application.Calculation = xlAutomatic
    ActiveSheet.DisplayPageBreaks = True
    Application.EnableEvents = True
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = True
    
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit

End Sub

---

我在上面发表了以下评论：，“您的代码将I4:M4转置为O11粘贴到另一页上，使用不同的源行粘贴200次。O11:O15将更改200次，但仅显示I204:M204的值。P4:T4和P11:P15也是如此。“此逻辑错误贯穿于代码中。或者可能有一些我不理解的东西，比如粘贴的公式或在后台工作的公式，以便相同的单元格在每个循环中获得不同的值

提高代码运行速度的关键是减少代码从工作表中读取或写入的次数。您可以在几乎与单个值相同的时间内将整个工作表读入数组。类似地，您可以在同一时间编写数千个值，而只需编写一个值。我的代码利用了这些事实。它读取一系列值，将这些值转换为内存中的转置数组，然后将新数组粘贴到目标区域。非常快。请注意顶部的常量

LastRow

。我只测试了14行代码，您可能也希望这样做。但是，在您的项目中，数字是

204

。请在代码中调整它

Sub Design()
    ' 128

    Const FirstRow      As Long = 4
    Const LastRow       As Long = 14
    
    Dim WsDes           As Worksheet        ' Worksheets("Frame Beam Design")
    Dim WsSum           As Worksheet        ' Worksheets("Frame Beam Summary")
    Dim ArrS            As Variant          ' intermediate storage of Source range's value
    Dim ArrT            As Variant          ' intermediate storage of Targe range's value
    Dim R               As Long             ' loop counter: rows
    Dim C               As Long             ' loop counter: columns
    Dim Cstart          As Long             ' start columns of second source groups relative to first
    Dim Ct              As Long             ' Column in ArrT
    Dim i               As Long             ' loop counter: ArrS(index)

    With Application
        .ScreenUpdating = False             ' useful
        .EnableEvents = False               ' useful if you have event procedures
        .Calculation = xlManual             ' of doubtful benefit here
    End With

    Set WsDes = Worksheets("Frame Beam Design")
    Set WsSum = Worksheets("Frame Beam Summary")
    
    With WsSum
        ArrS = .Range(.Cells(FirstRow, "I"), .Cells(LastRow, "T")).Value
        Cstart = .Columns("P").Column - .Columns("I").Column
    End With
    ' create an array with 5 rows and twice as many columns as ArrS has rows
    ReDim ArrT(1 To 5, 1 To UBound(ArrS) * 2)
    Ct = 1
    For R = LBound(ArrS) To UBound(ArrS)
        For i = 0 To Cstart Step Cstart
            For C = 1 To 5
                ArrT(C, Ct) = ArrS(R, C + i)
            Next C
            Ct = Ct + 1
        Next i
    Next R
    WsDes.Cells(11, "O").Resize(UBound(ArrT), UBound(ArrT, 2)).Value = ArrT
    
    With WsSum
        ArrS = .Range(.Cells(FirstRow, "W"), .Cells(LastRow, "AI")).Value
        Cstart = .Columns("AB").Column - .Columns("w").Column
    End With
    ' create an array with 3 rows and thrice as many columns as ArrS has rows
    ReDim ArrT(1 To 3, 1 To UBound(ArrS) * 3)
    Ct = 1
    For R = LBound(ArrS) To UBound(ArrS)
        For i = 0 To (Cstart * 2) Step Cstart
            For C = 1 To 3
                ArrT(C, Ct) = ArrS(R, C + i)
            Next C
            Ct = Ct + 1
        Next i
    Next R
    WsDes.Cells(35, "R").Resize(UBound(ArrT), UBound(ArrT, 2)).Value = ArrT
   
    'from Design to Summary
    With WsDes
        ' not clear, why you want to change these ranges 200 times
        ' just to display the value in WsSum.Cells(LastRow, [Clm])
        .Range("ETABS_U").Value = WsSum.Cells(LastRow, "C")
        .Range("End1Mu").Value = WsSum.Cells(LastRow, "D")
        .Range("MidMu").Value = WsSum.Cells(LastRow, "E")
        .Range("End2Mu").Value = WsSum.Cells(LastRow, "F")
        .Cells(24, "F").Value = WsSum.Cells(LastRow, "G")
        .Cells(23, "H").Value = WsSum.Cells(LastRow, "H")
    
        .Range("O28:O29").Copy
        WsSum.Cells(LastRow, "N").PasteSpecial Paste:=xlPasteValues, Transpose:=True
        .Range("P28:P29").Copy
        WsSum.Cells(LastRow, "U").PasteSpecial Paste:=xlPasteValues, Transpose:=True
    End With

    'from Design to Summary
    WsSum.Range("Z" & R & ":" & "AA" & R).Value = WsDes.Range("Y35:Z35").Value
    WsSum.Range("AE" & R & ":" & "AF" & R).Value = WsDes.Range("Y36:Z36").Value
    WsSum.Range("AJ" & R & ":" & "AK" & R).Value = WsDes.Range("Y37:Z37").Value
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = xlAutomatic
    End With
End Sub

在代码的前两部分中，我通过向右扩展列来解决目标单元格的重复问题。我的代码的重要部分是创建数组，这是正确完成的。如何将它们写入工作表只是一个小小的调整。我希望你能做到

我的方法不适用于过程第3节中的命名范围，因为我不知道它们的大小。我稍微修改了您的语法，但没有提供问题的解决方案。最后一节只是1和2的重复，稍作修改，我认为您应该能够复制前面几节中适合您的内容

---

如果可以的话，我有一条建议：不要将单元格称为“范围”。正确的语法是

Ws.Cells（[行编号]，[名称的列编号]）

。范围由其名称（即字符串）寻址。Excel提供默认名称，并使用单元格坐标连接这些名称。正如您所发现的，在代码中复制这是一个极其繁琐的过程。不要创建VBA然后将其转换为数字的字符串（将数字连接到字符串后），而是通过其第一个和最后一个单元格来定义范围，例如，

range（单元格（1,2）、cells（14,7））

，这相当于B1:G14或

range（单元格（1,B）、cells（14,G））

或range（“B”&2&“：G”&14）.

感谢所有为此做出贡献的人！这太棒了。我修改了一点，但现在快多了

Option Explicit

Sub design()
    
    Const ProcName As String = "design"
    ' If you start getting error messages in the Immediate window,
    ' then out-comment the following line to see where the error is occurring.
    ' When the problem is solved, uncomment the line.
    On Error GoTo clearError

    Dim MFrow, LFrow As Integer
         
    MFrow = Range("Starti").Value
    LFrow = Range("Endi").Value
     
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.Calculation = xlCalculationManual
    
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim smr As Worksheet
    Set smr = wb.Worksheets("Frame Beam Summary")
    Dim des As Worksheet
    Set des = wb.Worksheets("Frame Beam Design")
    
    ' 5 cells
    Dim s1 As Range: Set s1 = smr.Columns("I:M")
    Dim d1 As Range: Set d1 = des.Range("O11").Resize(s1.Columns.Count)
    Dim s2 As Range: Set s2 = smr.Columns("P:T")
    Dim d2 As Range: Set d2 = des.Range("P11").Resize(s2.Columns.Count)
    ' 3 cells
    Dim s3_1 As Range: Set s3_1 = smr.Columns("W:Y")
    Dim s3_2 As Range: Set s3_2 = smr.Columns("AB:AD")
    Dim s3_3 As Range: Set s3_3 = smr.Columns("AG:AI")
    Dim d3 As Range: Set d3 = des.Range("R35:T37")
    ' 1 cell
    Dim s4 As Range: Set s4 = smr.Columns("C:H")
    ' 2 cells
    Dim s5 As Range: Set s5 = smr.Columns("N:O")
    Dim d5 As Range: Set d5 = des.Range("O28").Resize(s1.Columns.Count)
    Dim s6 As Range: Set s6 = smr.Columns("U:V")
    Dim d6 As Range: Set d6 = des.Range("P28").Resize(s1.Columns.Count)
    ' 2 cells
    Dim s7_1 As Range: Set s7_1 = smr.Columns("Z:AA")
    Dim s7_2 As Range: Set s7_2 = smr.Columns("AE:AF")
    Dim s7_3 As Range: Set s7_3 = smr.Columns("AJ:AK")
    Dim d7_1 As Range: Set d7_1 = des.Range("Y35:Z35")
    Dim d7_2 As Range: Set d7_2 = des.Range("Y36:Z36")
    Dim d7_3 As Range: Set d7_3 = des.Range("Y37:Z37")
    
    Dim i As Long
    For i = MFrow To LFrow
        
        If i Mod 10 = 0 Then
        
            Application.StatusBar = i & "/" & LFrow - MFrow
        
        End If
        
        Range("ETABS_U").Value = s4.Cells(i, 1).Value
              
        'from Summary to Design
        d1.Value = Application.Transpose(s1.Rows(i).Value)
        d2.Value = Application.Transpose(s2.Rows(i).Value)
        
        
        d3.Rows(1).Value = s3_1.Rows(i).Value
        d3.Rows(2).Value = s3_2.Rows(i).Value
        d3.Rows(3).Value = s3_3.Rows(i).Value
        
        ' Maybe
        'des.Calculate
        ' Or just:
        Application.Calculation = xlAutomatic
        DoEvents
        Application.Calculation = xlCalculationManual
       
        'from Design to Summary
        
        s4.Cells(i, 2).Value = Range("End1Mu").Value
        s4.Cells(i, 3).Value = Range("MidMu").Value
        s4.Cells(i, 4).Value = Range("End2Mu").Value
        s4.Cells(i, 5).Value = des.Range("F24").Value
        s4.Cells(i, 6).Value = des.Range("H23").Value
       
        'from Design to Summary
        s5.Rows(i).Value = Application.Transpose(d5.Value)
        s6.Rows(i).Value = Application.Transpose(d6.Value)
        
        'from Design to Summary

        s7_1.Rows(i).Value = d7_1.Value
        s7_2.Rows(i).Value = d7_2.Value
        s7_3.Rows(i).Value = d7_3.Value

        ' Maybe
        'smr.Calculate
        
        
        
    Next i

ProcExit:
    
    Application.Calculation = xlAutomatic
    ActiveSheet.DisplayPageBreaks = True
    Application.EnableEvents = True
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = True
    
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit

End Sub

---

您的代码将I4:M4转置为O11粘贴到另一页上，使用不同的源行粘贴200次。O11:O15将更改200次，但仅显示I204:M204的值。与P4:T4和P11:P15相同。

Option Explicit

Sub design()
    
    Const ProcName As String = "design"
    ' If you start getting error messages in the Immediate window,
    ' then out-comment the following line to see where the error is occurring.
    ' When the problem is solved, uncomment the line.
    On Error GoTo clearError

    Dim MFrow, LFrow As Integer
         
    MFrow = Range("Starti").Value
    LFrow = Range("Endi").Value
     
    Application.ScreenUpdating = False
    Application.DisplayStatusBar = True
    Application.EnableEvents = False
    ActiveSheet.DisplayPageBreaks = False
    Application.Calculation = xlCalculationManual
    
    Dim wb As Workbook
    Set wb = ThisWorkbook
    Dim smr As Worksheet
    Set smr = wb.Worksheets("Frame Beam Summary")
    Dim des As Worksheet
    Set des = wb.Worksheets("Frame Beam Design")
    
    ' 5 cells
    Dim s1 As Range: Set s1 = smr.Columns("I:M")
    Dim d1 As Range: Set d1 = des.Range("O11").Resize(s1.Columns.Count)
    Dim s2 As Range: Set s2 = smr.Columns("P:T")
    Dim d2 As Range: Set d2 = des.Range("P11").Resize(s2.Columns.Count)
    ' 3 cells
    Dim s3_1 As Range: Set s3_1 = smr.Columns("W:Y")
    Dim s3_2 As Range: Set s3_2 = smr.Columns("AB:AD")
    Dim s3_3 As Range: Set s3_3 = smr.Columns("AG:AI")
    Dim d3 As Range: Set d3 = des.Range("R35:T37")
    ' 1 cell
    Dim s4 As Range: Set s4 = smr.Columns("C:H")
    ' 2 cells
    Dim s5 As Range: Set s5 = smr.Columns("N:O")
    Dim d5 As Range: Set d5 = des.Range("O28").Resize(s1.Columns.Count)
    Dim s6 As Range: Set s6 = smr.Columns("U:V")
    Dim d6 As Range: Set d6 = des.Range("P28").Resize(s1.Columns.Count)
    ' 2 cells
    Dim s7_1 As Range: Set s7_1 = smr.Columns("Z:AA")
    Dim s7_2 As Range: Set s7_2 = smr.Columns("AE:AF")
    Dim s7_3 As Range: Set s7_3 = smr.Columns("AJ:AK")
    Dim d7_1 As Range: Set d7_1 = des.Range("Y35:Z35")
    Dim d7_2 As Range: Set d7_2 = des.Range("Y36:Z36")
    Dim d7_3 As Range: Set d7_3 = des.Range("Y37:Z37")
    
    Dim i As Long
    For i = MFrow To LFrow
        
        If i Mod 10 = 0 Then
        
            Application.StatusBar = i & "/" & LFrow - MFrow
        
        End If
        
        Range("ETABS_U").Value = s4.Cells(i, 1).Value
              
        'from Summary to Design
        d1.Value = Application.Transpose(s1.Rows(i).Value)
        d2.Value = Application.Transpose(s2.Rows(i).Value)
        
        
        d3.Rows(1).Value = s3_1.Rows(i).Value
        d3.Rows(2).Value = s3_2.Rows(i).Value
        d3.Rows(3).Value = s3_3.Rows(i).Value
        
        ' Maybe
        'des.Calculate
        ' Or just:
        Application.Calculation = xlAutomatic
        DoEvents
        Application.Calculation = xlCalculationManual
       
        'from Design to Summary
        
        s4.Cells(i, 2).Value = Range("End1Mu").Value
        s4.Cells(i, 3).Value = Range("MidMu").Value
        s4.Cells(i, 4).Value = Range("End2Mu").Value
        s4.Cells(i, 5).Value = des.Range("F24").Value
        s4.Cells(i, 6).Value = des.Range("H23").Value
       
        'from Design to Summary
        s5.Rows(i).Value = Application.Transpose(d5.Value)
        s6.Rows(i).Value = Application.Transpose(d6.Value)
        
        'from Design to Summary

        s7_1.Rows(i).Value = d7_1.Value
        s7_2.Rows(i).Value = d7_2.Value
        s7_3.Rows(i).Value = d7_3.Value

        ' Maybe
        'smr.Calculate
        
        
        
    Next i

ProcExit:
    
    Application.Calculation = xlAutomatic
    ActiveSheet.DisplayPageBreaks = True
    Application.EnableEvents = True
    Application.DisplayStatusBar = True
    Application.ScreenUpdating = True
    
    Exit Sub

clearError:
    Debug.Print "'" & ProcName & "': Unexpected Error!" & vbLf _
              & "    " & "Run-time error '" & Err.Number & "':" & vbLf _
              & "        " & Err.Description
    Resume ProcExit

End Sub