我有一个代码，无法根据自动筛选器条件将数据从多个工作表复制到一个工作表中。
我尝试过这段代码，它正在复制不同工作表中的数据，但在应用自动过滤条件时，它会停止工作
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（）
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
结束子
函数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