Jules;653434 Wrote:
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
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.
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
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
--------------------
--
p45cal
*p45cal*
------------------------------------------------------------------------
p45cal's Profile: 558
View this thread:
http://www.thecodecage.com/forumz/sh...d.php?t=182350
Microsoft Office Help