It's perfect! Thanks so much for your help and time!!

"p45cal" wrote:


Jules;654173 Wrote:

Something else I just noticed, when it sorts and copies all the data to
the
summary sheet, it also copies the summary sheet data and pastes it on
the
summary sheet. I think the " Variation" specification will fix that
but, just
fyi.


Added a couple of lines highlighted in magenta.


Jules;654173 Wrote:

Also, while you're looking at it, is there a way to copy the headers
from
each page in the row beneath the sheet name on the summary page? So it
would
have sheet name in A1, headers in A2:D2, data in A3:D?...skip a
line...sheet
name, headers, data and so forth?



Commented out 1 line and replaced it with the simpler line in red below
it.

Untested:



VBA Code:
--------------------




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

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'Set the destination worksheet
Set DestSh = Sheets("SummaryOOL")

For Each sht In ActiveWorkbook.Sheets
If Right(UCase(sht.Name), 10) = " VARIATION" Then
sht.Select
Set My_Range = Range("A1:D" & LastRow(ActiveSheet))
My_Range.Parent.Select


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

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)
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then
DestSh.Range("A" & LastRow(DestSh) + 2) = My_Range.Parent.Name
'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
End If
Next sht
ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("A1")
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With
End Sub


--------------------


--
p45cal

*p45cal*
------------------------------------------------------------------------
p45cal's Profile: 558
View this thread: http://www.thecodecage.com/forumz/sh...d.php?t=182350

Microsoft Office Help

.