加快复制/粘贴范围

如果您不知道，关闭Application.ScreenUpdating并将Application.Calculation设置为manual也会提高代码的执行速度。

联合范围版本

Sub CopyRangeToSheetUnion()

    ' Source
    Const SOURCE_WORKSHEET_ID As Variant = "Sheet1"
    Const SOURCE_RANGE_ADDRESS As String = "A1:J10"
    Const SOURCE_CRITERIA_COLUMN_INDEX As Long = 1
    ' Destination
    Const DESTINATION_WORKSHEET_ID As Variant = "Sheet2"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
    
    ' Workbook
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_WORKSHEET_ID)
    Dim srg As Range: Set srg = sws.Range(SOURCE_RANGE_ADDRESS)
    
    Dim surg As Range
    Dim sCell As Range
    
    For Each sCell In srg.Columns(SOURCE_CRITERIA_COLUMN_INDEX).Cells
        If Len(CStr(sCell.Value)) > 0 Then ' the source cell is not blank
            If surg Is Nothing Then ' combine the first cell
                Set surg = sCell
            Else ' combine all but the first cell
                Set surg = Union(surg, sCell)
            End If
        'Else ' the source cell is blank; do nothing
        End If
    Next sCell
    
    If surg Is Nothing Then Exit Sub ' all cells are blank
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(DESTINATION_WORKSHEET_ID)
    Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    
    ' Copy.
    
    Intersect(srg, surg.EntireRow).Copy dfCell

End Sub

数组版本

下面是一个带有条件的示例，该条件复制“A”列中没有空白单元格的每一行（我将很快使用Union方法发布一个带有条件的示例）。

Sub CopyRangeToSheetArray()

    ' Source
    Const SOURCE_WORKSHEET_ID As Variant = "Sheet1"
    Const SOURCE_RANGE_ADDRESS As String = "A1:J10"
    Const SOURCE_CRITERIA_COLUMN_INDEX As Long = 1
    ' Destination
    Const DESTINATION_WORKSHEET_ID As Variant = "Sheet2"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
    
    ' Workbook
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_WORKSHEET_ID)
    Dim srg As Range: Set srg = sws.Range(SOURCE_RANGE_ADDRESS)
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim cCount As Long: cCount = srg.Columns.Count
    
    ' Write the values from the Source range to a 2D one-based array.
    Dim Data() As Variant: Data = srg.Value

    ' Modify.
    
    Dim sr As Long ' Array Source Rows Counter
    Dim c As Integer ' Array Columns Counter
    Dim dr As Long ' Array Destination Rows Counter/Count
    
    ' Return the rows of condition-met data at the top of the array.
    For sr = 1 To srCount
        If Len(CStr(Data(sr, SOURCE_CRITERIA_COLUMN_INDEX))) > 0 Then ' not bl.
            dr = dr + 1
            For c = 1 To cCount
                ' Write from source row to destination row.
                Data(dr, c) = Data(sr, c)
            Next c
        'Else ' is blank; do nothing
        End If
    Next sr
    
    ' Destination
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(DESTINATION_WORKSHEET_ID)
    Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    Dim drg As Range: Set drg = dfCell.Resize(dr, cCount)
    
    ' Copy.
    
    drg.Value = Data

End Sub

开胃菜
下面是一个不带任何条件复制特定范围的示例。您可以更改（增加）常量部分中的值。玩一下它，看看它有多快，并更好地了解它是如何工作的。我很快就会发布一个带条件的示例。

Sub CopyRangeToSheet()

    ' Source
    Const SOURCE_WORKSHEET_ID As Variant = "Sheet1"
    Const SOURCE_RANGE_ADDRESS As String = "A1:J10"
    ' Destination
    Const DESTINATION_WORKSHEET_ID As Variant = "Sheet2"
    Const DESTINATION_FIRST_CELL_ADDRESS As String = "A1"
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' Source
    Dim sws As Worksheet: Set sws = wb.Worksheets(SOURCE_WORKSHEET_ID)
    Dim srg As Range: Set srg = sws.Range(SOURCE_RANGE_ADDRESS)
    ' Destination
    Dim dws As Worksheet: Set dws = wb.Worksheets(DESTINATION_WORKSHEET_ID)
    Dim dfCell As Range: Set dfCell = dws.Range(DESTINATION_FIRST_CELL_ADDRESS)
    Dim drg As Range: Set drg = dfCell.Resize(srg.Rows.Count, srg.Columns.Count)
    
    ' Copy.
    drg.Value = srg.Value

End Sub

我发现先对整个表进行排序，然后在复制整个表之前使用筛选器，这比复制每一行要快得多。

'Number of rows
lonYMax = Sheets("YourTable").Cells(Rows.Count, 1).End(xlUp).Row

ActiveSheet.Range("$A$1:$AE$" & lonYMax).AutoFilter Field:=24, Criteria1:= _
   "Your filter"
Range("A1:AE" & lonYMax).Select
'Copy whole section
Selection.Copy
Windows("OtherWorkbook.xlsx").Activate
Range("A1").Select
'Insert bulk
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveWorkbook.Save
ActiveWindow.Close

尝试了一些方法，包括范围联合、数组等，将特定行从一个工作表复制到另一个工作表。
都需要时间。
这种方法论（一种不直接的方法）给了我更快的处理速度：
1.在第一个工作表填充条件评估值/字符串到一个新的/最后一列，并保持这个新的列单元格为空的行，我需要保留。
1.然后，将完整的工作表数据复制到新的工作表中

Range("A1:O" & nRows).Copy Destination:=Sheets(s2).Range("A1")

1.现在从sheet 1中删除了所有条件填充行

For rw = nRows To 2 Step -1 ' from bottom to top looping
        If Cells(rw, "O") <> "" Then
            Rows(rw).EntireRow.Delete
        End If
    Next

1.从sheet 2中删除了所有无条件行

Sheets(s2).Select
    For rw = nRows To 2 Step -1 ' from bottom to top looping
        If IsEmpty(Cells(rw, "O")) Then
            Rows(rw).EntireRow.Delete
        End If
    Next

这绝对不是一种直接的方法，
然而，直接将行从一个工作表复制到另一个工作表的VBA代码
并且使用范围并使用联合追加将消耗大量的处理时间。
这里的技巧是一次复制完整的数据，无论是否使用筛选器。然而，在此之后，删除行操作不会消耗太多时间。
我在这里只提到了理解逻辑所需的步骤代码。
我会很高兴知道，如果任何其他直接的方法工作更快，请评论。

不确定这是否适用，但是，复制单元格而不是行在一种情况下会产生巨大的差异。
我有一个“待办事项列表”Excel工作簿，其中大约有30个工作表，所有工作表都采用相同的“待办事项”列格式。当我按下控件窗体上的按钮时，VBA会通读每个工作表（“详细信息”工作表）并找到具有非空优先级列的“待办事项”行。然后将这些行中的每一行复制到工作簿前面的“操作”工作表中，因此所有细节工作表中的所有操作项都可以在一个列表中看到。还有一些其他功能，如格式化、排序和将复制的操作工作表行链接回源工作表。
我用这个代码从细节表复制到操作表。总共有大约200个操作项，这需要多达几分钟。

ws.Rows(n).EntireRow.Copy  '''' Detail sheet row
   aws.Rows(awsAddRow).EntireRow.PasteSpecial ''''' Action sheet row

我把上面的代码改成了这个，一列一列的复制单元格，花了几秒钟的时间。

For cl2 = 1 To 30
      aws.Cells(awsAddRow, cl2) = ws.Cells(n, cl2)
   Next cl2

格式和链接等似乎都很好。