根据自动筛选条件将工作簿中的多个工作表复制到摘要工作表

Question

我有一个代码无法根据自动过滤条件将数据从多个工作表复制到单个工作表中。

我有此代码，它正在从不同的工作表复制数据，但在应用自动过滤条件时它停止工作

Sub CopyDataWithoutHeaders()
Dim sh As Worksheet
Dim DestSh As Worksheet
Dim Last As Long
Dim shLast As Long
Dim CopyRng As Range
Dim StartRow As Long
Dim WSNew As Worksheet
Dim MyRange As Range
Dim my_range As Range
Dim Rng As Range
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
'Add a worksheet
'Set DestSh = ActiveWorkbook.Worksheets.Add
Set DestSh = ActiveWorkbook.Worksheets("Sheet16")
'DestSh.Name = "Destination"
'Fill in the start row
StartRow = 2
'loop through all worksheets and copy the data to the DestSh
For Each sh In ActiveWorkbook.Worksheets
    If IsError(Application.Match(sh.Name, _
        Array(DestSh.Name, "Format", "Lookups"), 0)) And sh.Visible = True Then
        'Find the last row with data on the DestSh and sh
        Last = LastRow(DestSh)
        shLast = LastRow(sh)
        MsgBox sh.Name
        Set my_range = Range("A1:ZZ" & LastRow(ActiveSheet))
        my_range.Parent.Select
        'If sh is not empty and if the last row >= StartRow copy the CopyRng
        If shLast >= StartRow Then
            my_range.Parent.AutoFilterMode = False
            ActiveSheet.Range("A1").AutoFilter Field:=22, Criteria1:="=Ready to import"
            'ActiveSheet.AutoFilter.Range.Offset(1, 0).Rows.SpecialCells(xlCellTypeVisible).Copy
            With my_range.Parent.AutoFilter.Range
                Set Rng = .Offset(1, 0).Resize(.Rows.Count, .Columns.Count) _
                    .SpecialCells(xlCellTypeVisible)
                    MsgBox my_range
                    If Not Rng Is Nothing Then
                        'Copy and paste the cells into DestSh below the existing data
                        Rng.Copy
                        With DestSh.Range("A" & LastRow(DestSh) + 1)
                            .PasteSpecial Paste:=8
                            .PasteSpecial xlPasteValues
                            .PasteSpecial xlPasteFormats
                             Application.CutCopyMode = False
                         End With
                     End If
'            Intersect(.UsedRange, .UsedRange.Offset(1)).SpecialCells(xlCellTypeVisible).Copy
'            DestSh.Cells(Rows.Count, 1).End(xlUp).Offset(1).PasteSpecial xlPasteValues  
                    MsgBox Last
'        With DestSh.Cells(Last + 1, "A")
'        .PasteSpecial Paste:=8
'            .PasteSpecial xlPasteValues
'            .PasteSpecial xlPasteFormats
'             Application.CutCopyMode = False
'            .Select
'        End With
 ' End If
                    'Close AutoFilter
                    my_range.Parent.AutoFilterMode = False
                    'Set the range that you want to copy
                    ' Set CopyRng = sh.Range(sh.Rows(StartRow), sh.Rows(shLast))
                    'Test if there enough rows in the DestSh to copy all the data
'                If Last + MyRange.Rows.Count > DestSh.Rows.Count Then
'                   MsgBox "There are not enough rows in the Destsh"
'                    GoTo ExitTheSub
'                End If
                'This example copies values/formats, if you only want to copy the
                'values or want to copy everything look below example 1 on this page
'                CopyRng.Copy
'                With DestSh.Cells(Last + 1, "A")
'                    .PasteSpecial xlPasteValues
'                    .PasteSpecial xlPasteFormats
'                    Application.CutCopyMode = False
            End With
        End If
        'End If
'ExitTheSub:
'
'    Application.Goto DestSh.Cells(1)
'
'    'AutoFit the column width in the DestSh sheet
'    DestSh.Columns.AutoFit
'
'    With Application
'        .ScreenUpdating = True
'        .EnableEvents = True
   'End With
End Sub

Function LastRow(sh As Worksheet)
    On Error Resume Next
    LastRow = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByRows, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Row
    On Error GoTo 0
End Function

Function LastCol(sh As Worksheet)
    On Error Resume Next
    LastCol = sh.Cells.Find(What:="*", _
                            After:=sh.Range("A1"), _
                            Lookat:=xlPart, _
                            LookIn:=xlFormulas, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlPrevious, _
                            MatchCase:=False).Column
    On Error GoTo 0
End Function

如果工作表符合条件，则应一个接一个地复制工作表。

Answer 1

这是基本代码执行您要完成的任务。

Sub CopyDataWithoutHeaders()
    Dim ws As Worksheet, DestSh As Worksheet, Rng As Range
    Set DestSh = ThisWorkbook.Sheets("Sheet16")
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    For Each ws In ThisWorkbook.Sheets
        If ws.Name <> "Format" And ws.Name <> "Lookups" And ws.Name <> DestSh.Name Then
            'the below line will not select the complete range if a cell is empty in column 1
            'it can be changed to the way you want.
            Set Rng = ws.Range("A1", ws.Range("A1").End(xlDown).End(xlToRight))
            With Rng 'will copy all the range except the header row  
                .AutoFilter Field:=22, Criteria1:="Ready to import", Operator:=xlAnd
                .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
            End With
                'test if the first cell is empty before pasting 
                If DestSh.Range("A1") = "" Then
                    DestSh.Cells(Rows.Count, "A").End(xlUp).PasteSpecial xlPasteValues
                Else: DestSh.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
                End If
        End If
        'clean up each worksheet
        ws.AutoFilterMode = False
        Application.CutCopyMode = False
    Next ws
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Answer 2

谢谢你的帮助

问题已解决

Sub CopyDataWithoutHeaders((

Dim ws As Worksheet, DestSh As Worksheet, Rng As Range
Set DestSh = ThisWorkbook.Sheets("All")
With Application
    .ScreenUpdating = False
    .EnableEvents = False
End With
For Each ws In ThisWorkbook.Sheets
     If ws.Name <> "Format" And ws.Name <> "Lookups" And ws.Name <> DestSh.Name Then
        Set Rng = ws.UsedRange
        With Rng 'will copy all the range except the header row
           .AutoFilter Field:=22, Criteria1:="Ready to import", Operator:=xlAnd
           ***If (ws.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count > 1)*** Then
            .Offset(1, 0).Resize(Rng.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
            DestSh.Cells(Rows.Count, "A").End(xlUp).Offset(1).PasteSpecial xlPasteValues
           End If
        End With
    End If
    'clean up each worksheet
    ws.AutoFilterMode = False
    Application.CutCopyMode = False
Next ws
With Application
    .ScreenUpdating = True
    .EnableEvents = True
End With

结束子

函数最后一行(sh 作为工作表( 出错时恢复下一个 最后一行 = sh。Cells.Find(What：="*"， _ 之后：=sh。范围("A1"(， _ 查看：=xlPart， _ 查找：=xl公式， _ SearchOrder：=xlByRows， _ 搜索方向：=xl上一页， _ 匹配大小写：=假(。排 出错时转到 0结束功能