满足条件时，VBA 将行复制并粘贴到不同的工作簿

Question

目标是指定两个不同的条件，只要满足其中一个条件，主文件（thisworkbook）中的整行就会被复制，然后粘贴到新的工作簿中。

我认为问题与“if”函数有关，因为此代码适用于一个条件（创建新工作簿并在满足条件时将所有行添加到此工作簿）。

其他问题： 当主文件包含许多符合指定条件的观察时，此方法非常耗时。出于这个原因，如果有人能在这个问题上提出更好的解决方案，我将不胜感激。如果所有行都可以一次发布到正确的工作簿上，而不是一一粘贴行，那就太棒了。

Private Sub CommandButton2_Click()
    a = Worksheets("Sheet1").Cells(Rows.Count, 9).End(xlUp).Row
    'creating new workbooks
    Dim newDataOne As Workbook
    Dim newDataTwo As Workbook
    Set newDataOne = Workbooks.Add
    Set newDataTwo = Workbooks.Add
    ThisWorkbook.Worksheets("Sheet1").Activate
    Dim nameone As String
    Dim nametwo As String
    nameone = ThisWorkbook.Worksheets("Sheet1").Range("CQ21")
    nametwo = ThisWorkbook.Worksheets("Sheet1").Range("CQ22")
    For i = 10 To a
        If Worksheets("Sheet1").Cells(i, 1).Value = nameone Then
            Worksheets("Sheet1").Rows(i).Copy
            newDataOne.ActiveSheet.Activate
            b = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
            newDataOne.ActiveSheet.Cells(b + 1, 1).Select
            ActiveSheet.PasteSpecial xlPasteValuesAndNumberFormats
            ThisWorkbook.Worksheets("Sheet1").Activate
        End If
        If Worksheets("Sheet1").Cells(i, 1).Value = nametwo Then
            Worksheets("Sheet1").Rows(i).Copy
            newDataTwo.ActiveSheet.Activate
            h = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
            newDataTwo.ActiveSheet.Cells(h + 1, 1).Select
            ActiveSheet.PasteSpecial xlPasteValuesAndNumberFormats
            ThisWorkbook.Worksheets("Sheet1").Activate
        End If
    Next i
End Sub

>

Answer 1

试试这个：

If Worksheets("Sheet1").Cells(i, 1).Value = nameone Or Worksheets("Sheet1").Cells(i, 1).Value = nametwo Then
            Worksheets("Sheet1").Rows(i).Copy
            newDataOne.ActiveSheet.Activate
            b = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
            newDataOne.ActiveSheet.Cells(b + 1, 1).Select
            ActiveSheet.PasteSpecial xlPasteValuesAndNumberFormats
            ThisWorkbook.Worksheets("Sheet1").Activate
End If

您可以使用Or 指定两个条件，而不是创建两个If Then 语句。如果满足任一条件，则复制并粘贴该行。

关于运行代码所花费的时间，您通常应该避免使用.Select 和.Activate，您经常这样做。试试看你能否自己想出一个办法来避免这种情况——如果你不能，我今天晚些时候会帮你的。

Answer 2

我找不到关于第二个“if”的任何错误。例如，我建议检查CQ22 的值是否为错误。

尽量避免激活和选择以缩短运行代码的时间。

Private Sub CommandButton2_Click()
    a = Worksheets("Sheet1").Cells(Rows.Count, 9).End(xlUp).Row
    'creating new workbooks
    Dim newDataOne As Workbook
    Dim newDataTwo As Workbook
    Set newDataOne = Workbooks.Add
    Set newDataTwo = Workbooks.Add
    Dim nameone As String
    Dim nametwo As String
    nameone = ThisWorkbook.Worksheets("Sheet1").Range("CQ21")
    nametwo = ThisWorkbook.Worksheets("Sheet1").Range("CQ22")
    For i = 10 To a
        If ThisWorkbook.Worksheets("Sheet1").Cells(i, 1).Value = nameone Then
            ThisWorkbook.Worksheets("Sheet1").Rows(i).Copy
            b = newDataOne.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
            newDataOne.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 = newDataTwo.ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
            newDataTwo.ActiveSheet.Cells(h + 1, 1).PasteSpecial xlPasteValuesAndNumberFormats
        End If
    Next i
End Sub