Data Extract from Multiple Worksheets Macro

[EMarre]

I have recorded the Macro (please see below) in a formatted Profit and Loss
budget worksheet. The worksheet uses columns and rows Show/Hide Groups to
extract data from the worksheet using the 'Copy' Visible Cells only command
into another worksheet within the same workbook. I had done this to eliminate
totals, formats, etc. and be able to extract only Account and Projections
data entered by users into the worksheets. This data will be imported into a
budget system later on using a text format file. The issue I am having is
that one workbook could contain hundreds of departments P&L budget in
separate tabs or worksheets and I don't know how to loop through all the
worksheets using the same macro to extract the data using the referenced
macro.

Any help that could be provided on this issue will be really appreciated.

Thanks in advance,

Please see macro below:

Sub Data_Extract()
'
' Keyboard Shortcut: Ctrl+e
'
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
ActiveSheet.Outline.ShowLevels RowLevels:=1
Range("D20:AB700").Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets("Extracted Data for Import").Select
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("B2").Select
Sheets("Report").Select
Range("Z20").Select
Application.CutCopyMode = False
ActiveSheet.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
ActiveSheet.Outline.ShowLevels RowLevels:=2
End Sub

 

[Mr. m0le]

This is only a half a fix as I'm new to vb and not sure of all the code
possiblities...

do
your code
activesheet.next.select
loop

only problem with this is that you will get an error once your code is done
on the final tab/sheet as there isn't another sheet to move to. Sorry I
can't be of more help then that. Hopefully this will get you closer to a
solution.

 

[Jim Thomlinson]

Give this a try...

Sub Data_Extract()
Dim rngPaste As Range
Dim wksCopy As Worksheet
Dim wksPaste As Worksheet
Set wksPaste = Sheets("Extracted Data for Import")

For Each wksCopy In ThisWorkbook.Worksheets
If wksCopy.Name <> wksPaste.Name Then
With wksCopy
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=1
.Outline.ShowLevels RowLevels:=1
.Range("D20:AB700").SpecialCells(xlCellTypeVisible).Copy
Set rngPaste = wksPaste.Cells(Rows.Count,
"B").End(xlUp).Offset(1, 0)
rngPaste.PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
.Outline.ShowLevels RowLevels:=0, ColumnLevels:=2
.Outline.ShowLevels RowLevels:=2
End With
End If
Next wksCopy
End Sub

 

[EMarre]

Thanks so much for your reply and the tip. I really appreciate it and will
give it a try.

 

[EMarre]

Jim,

Thanks so much for your quick reply and for your help. You are a genious! It
works exactly as I need it.

There is only one more thing I need to correct and is the fact that the
extracted data is showing empty rows in-between some of the records (please
see below) due to some rows I can't group. Is there any way to add some code
to your procedure that loops through the output records in the Extrat Data
for Import worksheet and deletes the blank rows?

Thanks so much again for all your help,

Regards,

EMarre

67810 836
67810 840
67810 845
67810 846
67810 850
67810 851
67810 852
67810 855



67810 865
67810 870
67810 880
67810 885
67810 890
67810 895
67810 898
67810 899