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

我有一个代码无法根据自动筛选条件将多张图纸中的数据复制到一张图纸中

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

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

---

如果工作表符合标准，则应将其一张一张地复制到另一张的下方。

这是基本代码，它完成了您试图完成的任务

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

Sub-CopyDataWithoutHeaders（）
将ws作为工作表，将SH作为工作表，将Rng作为范围
Set DestSh=thiswoolk.Sheets（“Sheet16”）
应用
.ScreenUpdate=False
.EnableEvents=False
以
对于此工作簿中的每个ws.Sheets
如果ws.Name“格式”和ws.Name“查找”以及ws.Name DestSh.Name，那么
'如果第1列中的单元格为空，则下一行不会选择完整范围
“它可以按照你想要的方式改变。
设置Rng=ws.范围（“A1”，ws.范围（“A1”）。结束（xlDown）。结束（xlToRight））
使用Rng'将复制除标题行以外的所有范围
.AutoFilter字段：=22，准则1:=“准备导入”，运算符：=xlAnd
.Offset（1）.调整大小（.Rows.Count-1）.特殊单元格（xlCellTypeVisible）.复制
以
'粘贴前测试第一个单元格是否为空
如果DestSh.Range（“A1”）=则
DestSh.Cells（Rows.Count，“A”）.End（xlUp）.paste特殊xlpaste值
其他：DestSh.Cells（Rows.Count，“A”）.End（xlUp）.Offset（1）.粘贴特殊的xlpasteValue
如果结束
如果结束
'清理每个工作表
ws.AutoFilterMode=False
Application.CutCopyMode=False
下一个ws
应用
.ScreenUpdate=True
.EnableEvents=True
以
端接头

谢谢您的帮助

问题解决

子CopyDataWithoutHeaders（）

Dim ws As工作表、DestSh As工作表、Rng As范围
Set DestSh=thisvoolk.Sheets（“全部”）
应用
.ScreenUpdate=False
.EnableEvents=False
以
对于此工作簿中的每个ws.Sheets
如果ws.Name“格式”和ws.Name“查找”以及ws.Name DestSh.Name，那么
设置Rng=ws.UsedRange
使用Rng'将复制除标题行以外的所有范围
.AutoFilter字段：=22，准则1:=“准备导入”，运算符：=xlAnd
***如果（ws.AutoFilter.Range.Columns（1）.SpecialCells（xlCellTypeVisible）.Cells.Count>1）***则
。偏移量（1，0）。调整大小（Rng.Rows.Count-1）。特殊单元格（xlCellTypeVisible）。复制
DestSh.Cells（Rows.Count，“A”）.End（xlUp）.Offset（1）.粘贴特殊的xlpasteValue
如果结束
以
如果结束
'清理每个工作表
ws.AutoFilterMode=False
Application.CutCopyMode=False
下一个ws
应用
.ScreenUpdate=True
.EnableEvents=True
以

端接头

函数LastRow（sh作为工作表） 出错时继续下一步 LastRow=sh.Cells.Find（内容：=“*”_ 之后：=sh.Range（“A1”）_ 看：=xlPart_ LookIn:=xl公式_ 搜索顺序：=xlByRows_ 搜索方向：=xlPrevious_ MatchCase:=False）。行 错误转到0

---

结束函数

请正确发布您的所有代码，以便阅读。您是否真的需要标准中的

=

？我已经编辑了它。现在它开始抛出类型不匹配错误。您好，非常感谢您的帮助。它现在抛出应用程序或对象定义的错误。请提供帮助。如果您正在为自己的问题提供答案，您可能希望确定问题是如何解决的，以便其他审阅您的问题的人可以了解。范围未在定义中选取任何值。使用asterix中突出显示的if条件解决了该问题。

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