从过滤表中复制结果行忽略空白或空

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:ReportesPrueba"
    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

最好是事先解决目标并使用复制操作的目标参数。