一次将满足条件的行复制并粘贴到不同的工作簿

Question

我需要根据 id 将 masterfile(thisworkbook) 中的行传递到不同的工作簿。我目前在代码中遇到的问题是，一一复制和粘贴所有行太慢了，因为主文件非常大，之后我想在我的代码中添加更多条件（和工作簿）。

我当前的代码，只要满足条件，就逐行复制粘贴：

Private Sub CommandButton2_Click()
    a = Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
    Dim newWorkbookOne As Workbook, newWorkbookTwo As Workbook
    Set newWorkbookOne = Workbooks.Add
    Set newWorkbookTwo = Workbooks.Add
    Dim conditionOne As String, conditionTwo as String
    Set conditionOne = "value1"
    Set conditionTwo = "value2"
    For i = 2 To a
        If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = conditionOne Then
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy
        b = newWorkbookOne.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        newWorkbookOne.ActiveSheet.Cells(b + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    End If
    If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = nametwo Then
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy
        h = newWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        newWorkbookTwo.ActiveSheet.Cells(h + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats

    End If
  Next 'something

此代码非常耗时，并且绝对不适合较大的文件。出于这个原因，我想一次将所有行粘贴到这些新工作簿中。有人对此问题有解决方案吗？

Answer 1

1) 设置Application.ScreenUpdating = False

2) 您可以将所有行粘贴到一个数组中，而不是一一复制行，然后在循环完成时将它们全部插入。需要时间的是插入，而不是复制。

试试这个：

Dim newWorkbookOne As Workbook, newWorkbookTwo As Workbook
Dim conditionOne As String, conditionTwo as String
Dim arr1 (0 to 999) as Variant ' change parameters as required
Dim arr2 (0 to 999) as Variant ' change parameters as required
Dim j as Integer, n as Integer

a = Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
Set newWorkbookOne = Workbooks.Add
Set newWorkbookTwo = Workbooks.Add

Set conditionOne = "value1"
Set conditionTwo = "value2"
For i = 2 To a
    If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = conditionOne Then
    arr(j) = ThisWorkbook.Worksheets("Sheet1").Rows(i)
    j = j + 1
End If
If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = nametwo Then
    arr2(n) = ThisWorkbook.Worksheets("Sheet1").Rows(i)
    n = n + 1
End If
Next 'something

' Insert the values of the arrays in the two new worksheets here

编辑#1：插入数组值

lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row ' change sheet to what's appropriate

For i = LBound(arr) To UBound(arr)
    Rows(lastRow + 1 + i).Value2 = arr(i) ' presupposes the array starts at index 0
Next i

Answer 2

首先确保 ScreenUpdating 像这样关闭：

Private Sub CommandButton2_Click()
Application.ScreenUpdating = False
    a = Worksheets("Sheet1").Cells(Rows.Count, 2).End(xlUp).Row
    Dim newWorkbookOne As Workbook, newWorkbookTwo As Workbook
    Set newWorkbookOne = Workbooks.Add
    Set newWorkbookTwo = Workbooks.Add
    Dim conditionOne As String, conditionTwo as String
    Set conditionOne = "value1"
    Set conditionTwo = "value2"
    For i = 2 To a
        If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = conditionOne Then
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy
        b = newWorkbookOne.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        newWorkbookOne.ActiveSheet.Cells(b + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
    End If
    If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = nametwo Then
        ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy
        h = newWorkbook.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
        newWorkbookTwo.ActiveSheet.Cells(h + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats

    End If
  Next 'something
  Application.ScreenUpdating = True

这应该会大大减少时间消耗。

此外，如果您希望以不同的方式执行此操作，您可以考虑运行第一个 If 语句并隐藏您不想复制的所有行。然后一次性复制并粘贴相关范围内的所有可见行。然后取消隐藏它们并以相同的方式运行第二个 If 语句。
自己尝试一下，如果需要帮助，请告诉我 :)