如果使用宏满足某些条件，则将一些行从一个工作簿复制到另一个工作簿

Question

我有一本工作簿。如果满足某些条件，我需要从一个工作簿中提取一些行并保存到另一个工作簿中。我在 workbook1 的 sheet2 中有一个列，它要么是“真”，要么是“假”。如果在 sheet2 中获得“true”并且需要将其复制到另一个工作簿（workbook2），我需要从 sheet1 复制所有行。对 sheet1 中的列执行 EXACT 函数后获得 True 或 False。

请注意，我的 sheet1 不会有固定的列长。

我的代码：

Sub mySales()

Dim LastRow As Integer, i As Integer, erow As Integer

LastRow = ActiveSheet.Range(“A” & Rows.Count).End(xlUp).Row

For i = 2 To LastRow

If Cells(i, 1) = Date And Cells(i, 2) = “Sales” Then
Range(Cells(i, 1), Cells(i, 7)).Select
Selection.Copy

Workbooks.Open Filename:=”C:\Users\takyar\Documents\salesmaster-new.xlsx”
Worksheets(“Sheet1”).Select
erow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row

ActiveSheet.Cells(erow, 1).Select
ActiveSheet.Paste
ActiveWorkbook.Save
ActiveWorkbook.Close
Application.CutCopyMode = False
End If

Next i
End Sub

Answer 1

您可以使用AutoFilter() 方法一次性完成，按照以下代码（cmets 中的解释）：

Option Explicit

Sub mySales()
    With ActiveSheet ' reference "source" sheet
        With .Range("G1", .Cells(.Rows.Count, "A").End(xlUp))  'reference its column A:G cells from row 1 (header) down to last not empty one in column "A"
            .AutoFilter field:=1, Criteria1:="TRUE" ' filter referenced cells on 1st column with "TRU"E content
            If Application.WorksheetFunction.Subtotal(103, .Columns(1)) > 1 Then
                .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy ' copy filtered cells skipping headers
                With Workbooks.Open(Filename:="C:\Users\takyar\Documents\salesmaster-new.xlsx").Sheets("Sheet1") 'open wanted workbook and reference its wanted sheet
                    .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial 'paste filtered cells in referenced sheet from ist column A first empty cell after last not empty one
                    .Parent.Close True ' save and close referenced workbook
                End With
                Application.CutCopyMode = False
            End If
        End With
        .AutoFilterMode = False ' remove filters
    End With
End Sub

Answer 2

您只需要打开一次目标工作簿。

例如：

Sub mySales()
    'use Const for fixed values
    Const WB_PATH As String = "C:\Users\takyar\Documents\salesmaster-new.xlsx"
    Dim srcSht As Worksheet, wb As Workbook, shtDest As Workbook, i As Long

    Set srcSht = ActiveSheet

    For i = 2 To srcSht.Range("A" & srcSht.Rows.Count).End(xlUp).Row
        If srcSht.Cells(i, 1) = Date And Cells(i, 2) = "Sales" Then
            'is the destination workbook already open? If not, open it
            If shtDest Is Nothing Then
                Set wb = Workbooks.Open(Filename:=WB_PATH)
                Set shtDest = wb.Sheets("Sheet1")
            End If
            srcSht.Cells(i, 1).Resize(1, 7).Copy _
                     shtDest.Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
        End If
    Next i

    'save and close the destination workbook if it was opened
    If Not wb Is Nothing Then wb.Close True

End Sub