如何加快這個循環代碼？

Question

你能幫助任何人加快這段代碼嗎？我假設可以使用一個數組，但我使用它們很糟糕。有另一種方法嗎？非常感謝！

Application.ScreenUpdating =假

'IF using Indexed Values 


    If Sheets("interface").Range("C24") = "Y" Then 

    Dim x As Integer 
    Dim i As Long 

    For x = 15 To 51 

     LastRow = Sheets("db_main").Range("A" & Rows.Count).End(xlUp).Row 

     For i = 2 To LastRow 

      If Sheets("db_main").Range("S" & i) = True And Sheets("db_main").Range("C" & i) = Sheets("interface").Range("F" & x) Then 

       Sheets("db_main").Range("C" & i).Copy 
       Sheets("intersource").Range("A" & Rows.Count).End(xlUp).Offset(1).Select 
       Selection.PasteSpecial Paste:=xlPasteValues 

       Sheets("db_main").Range("A" & i).Copy 
       Sheets("intersource").Range("B" & Rows.Count).End(xlUp).Offset(1).Select 
       Selection.PasteSpecial Paste:=xlPasteValues 

       Sheets("db_main").Range("H" & i).Copy 
       Sheets("intersource").Range("C" & Rows.Count).End(xlUp).Offset(1).Select 
       Selection.PasteSpecial Paste:=xlPasteValues 

       Sheets("db_main").Range("D" & i).Copy 
       Sheets("intersource").Range("D" & Rows.Count).End(xlUp).Offset(1).Select 
       Selection.PasteSpecial Paste:=xlPasteValues 

       Sheets("db_main").Range("M" & i).Copy 
       Sheets("intersource").Range("E" & Rows.Count).End(xlUp).Offset(1).Select 
       Selection.PasteSpecial Paste:=xlPasteValues 

       Sheets("db_main").Range("O" & i).Copy 
       Sheets("intersource").Range("F" & Rows.Count).End(xlUp).Offset(1).Select 
       Selection.PasteSpecial Paste:=xlPasteValues 

      End If 
       Next i 

     Next x 

       End If 

Answer 1

如果你想避免使用數組，你可以嘗試消除有利於剛分配的值（這應該提高性能）的複製/粘貼。試試這個：

'IF using Indexed Values 
Application.ScreenUpdating = False 

If Sheets("interface").Range("C24") = "Y" Then 

Dim x As Long, i As Long, LastRow As Long, _ 
    LastSourceRow As Long, Counter As Long 
Dim DBSheet As Worksheet, SourceSheet As Worksheet, _ 
    InterSheet As Worksheet 

'identify worksheets for easier reference 
Set DBSheet = ThisWorkbook.Worksheets("db_main") 
Set SourceSheet = ThisWorkbook.Worksheets("intersource") 
Set InterSheet = ThisWorkbook.Worksheets("interface") 

For x = 15 To 51 

'identify last rows 
LastRow = DBSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 
LastSourceRow = SourceSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 
Counter = 1 

    For i = 2 To LastRow 

     If DBSheet.Range("S" & i) = True And DBSheet.Range("C" & i) = InterSheet.Range("F" & x) Then 

      'write DB column C to Source column A 
      SourceSheet.Cells(LastSourceRow + Counter, 1) = _ 
       DBSheet.Cells(i, 3).Value 

      'write DB column A to Source column B 
      SourceSheet.Cells(LastSourceRow + Counter, 2) = _ 
       DBSheet.Cells(i, 1).Value 

      'write DB column H to Source column C 
      SourceSheet.Cells(LastSourceRow + Counter, 3) = _ 
       DBSheet.Cells(i, 8).Value 

      'write DB column D to source column D 
      SourceSheet.Cells(LastSourceRow + Counter, 4) = _ 
       DBSheet.Cells(i, 4).Value 

      'write DB column M to Source column E 
      SourceSheet.Cells(LastSourceRow + Counter, 5) = _ 
       DBSheet.Cells(i, 13).Value 

      'write DB column O to Source column F 
      SourceSheet.Cells(LastSourceRow + Counter, 6) = _ 
       DBSheet.Cells(i, 15).Value 

      'increment counter 
      Counter = Counter + 1 

     End If 

    Next i 

Next x 

End If 
Application.ScreenUpdating = True