Question

大家。我是新手，但我需要这个，所以我请求你的帮助。我正在构建一个宏来将过滤后的数据从几本书复制到一本书。以下代码运行正常，直到一个筛选的工作表没有结果行，然后它复制一系列空单元格，在那一刻收到一个无法解决的错误1004。这是我的代码（根据我的需要改编代码的结果）：

Sub MergeDataFromWorkbooks()
    Dim wbk As Workbook
    Dim wbk1 As Workbook

    Set wbk1 = ThisWorkbook

    Dim Filename As String
    Dim Path As String

    Path = "D:\Reportes\Prueba\"
    Filename = Dir(Path & "*.xlsx")
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    Do While Len(Filename) > 0

        Set wbk = Workbooks.Open(Path & Filename)

        wbk.Activate

        If ActiveSheet.FilterMode Then
            ActiveSheet.ShowAllData
        End If

        With ActiveSheet
            .AutoFilterMode = False
            .Range("B6:BB6").AutoFilter field:=8, Criteria1:="*Nacional*"
        End With

        Range("B7").Select
        Range(Selection, "BA7").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.SpecialCells(xlCellTypeVisible).Select
        Selection.Copy

        Windows("Merged.xlsm").Activate

        Application.DisplayAlerts = False

        Dim lr As Double

        lr = wbk1.Sheets(1).Cells.Find(What:="*", _
                        After:=Range("A1"), _
                        LookAt:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).Row
        'Sheets("Hoja1").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        Sheets("Hoja1").Select
        Cells(lr + 1, 1).Select
        ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True

        Application.CutCopyMode = False
        wbk.Close True
        Filename = Dir
    Loop
    MsgBox "All the files are copied and pasted in Merged."

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

先谢谢。

对不起我的英文写作，这不是我的语言。

Answer 1

您必须检查是否有任何已过滤的单元格，因此请将复制/粘贴语句包装在某些If - Then内，如下所示：

    With ActiveSheet
        .AutoFilterMode = False
        .Range("B6:BB6").AutoFilter field:=8, Criteria1:="*Nacional*"
    End With

    If Application.WorksheetFunction.Subtotal(103, Intersect(ActiveSheet.UsedRange, Columns(2))) > 1 Then
        Range("B7").Select
        Range(Selection, "BA7").Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.SpecialCells(xlCellTypeVisible).Select
        Selection.copy
        Windows("Merged.xlsm").Activate

        Application.DisplayAlerts = False

        Dim lr As Double

        lr = wbk1.Sheets(1).Cells.Find(What:="*", _
                        After:=Range("A1"), _
                        LookAt:=xlPart, _
                        LookIn:=xlFormulas, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False).row
        'Sheets("Hoja1").Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        Sheets("Hoja1").Select
        Cells(lr + 1, 1).Select
        ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True

        Application.CutCopyMode = False
    End If

    wbk.Close True
    Filename = Dir

Answer 2

复制前检查过滤范围内的可见值。

With ActiveSheet
    .AutoFilterMode = False
    with .Range("B6:BB6")
        .AutoFilter field:=8, Criteria1:="*Nacional*"
        with .resize(.rows.count-1, .columns.count).offset(1, 0)
            if cbool(application.subtotal(103, .cells)) then
                .SpecialCells(xlCellTypeVisible).copy
            end if
        end with
    end with
End With

最好事先计算出目的地并使用复制操作的Destination参数。

从过滤后的工作表中复制结果行，忽略空白或空白

2 个答案: