一次将满足条件的行复制并粘贴到其他工作簿中

Question

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

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

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

首先确保像这样关闭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语句。
自己尝试一下，如果您需要帮助，请告诉我:)

Answer 2

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