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

我有一本练习册。如果满足某些条件，我需要从一个工作簿中删除一些行并保存到另一个工作簿中。我在workbook1的第2页中有一列是“真”或“假”。如果在sheet2中获得“true”，我需要复制sheet1中的所有行，并需要将其复制到另一个工作簿（workbook2）。对表1中的一列执行精确的函数后，可获得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

---

只需打开目标工作簿一次

例如：

---

您可以使用

AutoFilter（）

方法一次完成此操作，如下代码所示（注释中的解释）：

---

您的代码有什么问题？顺便说一句，您的报价是“智能报价”，而不是常规报价：不知道在实际的VBA项目中是否相同。注意：始终使用

Long

而不是

Integer

，尤其是在处理行计数时。Excel的行数超过了

Integer

所能处理的行数。使用

Integer

也没有任何好处。只是说在

shtDest.Cells（Rows.Count，1）.End（xlUp）.Offset（1，0）

中，实际上是在“计算”活动表的行数，而不是

shtDest

。一般而言，应注意明确参考所需图纸。我知道你知道这一点，但可能是qwww不知道srcSht.Cells（I，1）=Date和Cells（I，2）=“Sales”，那么如何将其替换为检查A列中的每个单元格是否为TRUE？

和Cells（I，2）=TRUE

@TimWilliams，甚至仅

和Cells（I，2）

因为我们依赖于列A的值为

布尔值

。自动筛选字段：=1，标准1:=CStr（日期）'筛选第一列上引用的单元格的当前日期内容。自动筛选字段：=2，标准1:=“Sales”如何替换此字段以检查列A中的每个单元格是否为真？@qwww，你的意思是你不必再匹配A列中的

日期

，而必须匹配：1）A列中的

True

和B列中的“Sales”？不，我不需要匹配日期。。相反，列A将具有true或false。。。因此，如果为真，则必须将sheet1中相应的行复制到新工作簿中。。。。假设在sheet2或wb1中，我的A列中有true或false。。如果A5为真，则必须将表1中的相应行（表1中的A5）复制到wb2@qwww，那么“B”列呢？你不再需要它来匹配“销售”了？哦…对不起…销售和日期不是必需的。。。只需检查真实情况

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

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