Modify RDB's Copy filtered data code to loop through multiple shee

J

Jules

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
 
J

Jules

Definitely on the right track. It errors out at "sht" because it was not
defined but once that's fixed, works great for all sheets in workbook. The
five sheets I need to apply this to all end in " Variation". I don't know
enough about VBA to work that in on my own. Can you help? Thanks muchly for
all of your help so far!

Jules

p45cal said:
Below is a great piece of code I lifted from RDB's website. It's set up
to


Try the below, but it's not finished...
it runs through -*all *-worksheets in the active workbook which is not
what you want, so what can be used to help identify only those sheets
you want to be processed? Does each have a something in its name which
is common? Perhaps something on the sheet itself can be checked?
I've added four lines, highlighted in the code in red at this thread at
codecage.com, and moved some other lines.
Post again if it looks like we're going in the right direction. The
code has not been tested.
Click to expand...
VBA Code:
Click to expand...
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
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)
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
Next sht
ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("A1")
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With

End Sub
Click to expand...
--------------------


--
p45cal

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

Microsoft Office Help

.
Click to expand...
 
J

Jules

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.

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?

Thanks again for all you help. You have no idea how much time this process
is going to save me each week!

Jules

p45cal said:
Below is a great piece of code I lifted from RDB's website. It's set up
to


Try the below, but it's not finished...
it runs through -*all *-worksheets in the active workbook which is not
what you want, so what can be used to help identify only those sheets
you want to be processed? Does each have a something in its name which
is common? Perhaps something on the sheet itself can be checked?
I've added four lines, highlighted in the code in red at this thread at
codecage.com, and moved some other lines.
Post again if it looks like we're going in the right direction. The
code has not been tested.
Click to expand...
VBA Code:
Click to expand...
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
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)
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
Next sht
ActiveWindow.View = ViewMode
Application.Goto DestSh.Range("A1")
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = CalcMode
End With

End Sub
Click to expand...
--------------------


--
p45cal

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

Microsoft Office Help

.
Click to expand...
 
J

Jules

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

p45cal said:
Something else I just noticed, when it sorts and copies all the data to
the


Added a couple of lines highlighted in magenta.


Also, while you're looking at it, is there a way to copy the headers
from


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

Untested:
Click to expand...
VBA Code:
Click to expand...
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
Click to expand...
--------------------


--
p45cal

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

Microsoft Office Help

.
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Autofilter in 1 workbook and paste in 2nd workbook 11
copy data from a hidden column to another sheet 1
Copy HIDDEN columns to a new workbook 2
Copy to worksheets 1
Private Sub Workbook_NewSheet not firing when new sheet created fromcode 2
Combining two different subs w/ similar variables 10
Help revising slow code 2
Ron de Bruin - Merge cells from all worksheets 0

Top