Below is a great piece of code I lifted from RDB's website. It's set up to
use AutoFilter to filter and copy the filtered results to a new worksheet. It
works great on a single sheet!!

I need to use this exact process but I need it to loop through multiple
sheets (but not all sheets) in my workbook. I need the data from all involved
sheets to be pasted onto the same destination sheet with a line inbetween
each that has the sheet name it came from.

For example, the result for two of the sheets combined (with LC Status and
IA status being sheet names) would look like:

Name ID Status Total
LC Status
Tennessee 208 Z Incomplete 48.63
Alabama 275 Y Incomplete 22.00
Texas 293 Y Incomplete 27.75
Oregon 295 X Incomplete 176.13
New York 417 Y Incomplete 24.25
Missouri 1002 X Incomplete 86.75

IA Status
Arkansas 202 X Incomplete 520.13
Tennessee 208 Z Incomplete 19.80
Georgia 211 Y Incomplete 38.40
Kentucky 212 Y Incomplete 37.35
New Jersey 239 X Incomplete 110.78


Any ideas for modifying the below code would be most appreciated!!

Jules

----------------------------------------------------
Sub Copy_With_AutoFilter2()

Dim My_Range As Range
Dim DestSh As Worksheet
Dim CalcMode As Long
Dim ViewMode As Long
Dim FilterCriteria As String
Dim CCount As Long
Dim rng As Range

Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
My_Range.Parent.Select

'Set the destination worksheet
Set DestSh = Sheets("SummaryOOL")

If ActiveWorkbook.ProtectStructure = True Or _
My_Range.Parent.ProtectContents = True Then
MsgBox "Sorry, does not work when the workbook or worksheet is
protected", _
vbOKOnly, "Copy to new worksheet"
Exit Sub
End If

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
ActiveSheet.DisplayPageBreaks = False

My_Range.Parent.AutoFilterMode = False

'Use "<Out of Limit" as criteria if you want the opposite
My_Range.AutoFilter Field:=C, Criteria1:="=Incomplete"


'Check if there are not more then 8192 areas(limit of areas that Excel
can copy)
CCount = 0
On Error Resume Next
CCount =
My_Range.Columns(1).SpecialCells(xlCellTypeVisible ).Areas(1).Cells.Count
On Error GoTo 0
If CCount = 0 Then
MsgBox "There are more than 8192 areas:" _
& vbNewLine & "It is not possible to copy the visible data." _
& vbNewLine & "Tip: Sort your data before you use this macro.", _
vbOKOnly, "Copy to worksheet"
Else

With My_Range.Parent.AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, .Columns.Count) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
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
'Delete the rows in the My_Range.Parent worksheet
'rng.EntireRow.Delete
End If
End With
End If

'Close AutoFilter
My_Range.Parent.AutoFilterMode = False

ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("A1")
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With

End Sub