Apply maco to multiple worksheets request

J

joecrabtree

All,

I have the following code which runs on a 'data' worksheet summarizes
the data and copies it to the 'output' spreadsheet. This works fine.
However what i would like to do is run it for all sheets which have
the name format 'DATA xxxxxxx' the xxxxxxx is a date with the format
2009.02.11 and this could vary. I would then like to create an
individual output sheet for each DATA worksheet labelled 2009.02.11
OUTPUT etc for each date. How can I modify the code to do this? Thanks
in advance for your help.

Regards,

Joseph Crabtree

Sub summarysheet()




For Each Sh In ThisWorkbook.Worksheets


With Sheets("Data")
LastRow = Sheets("Data").Range("R" & Rows.Count).End(xlUp).Row
Set CodeRange = .Range("R2:R" & LastRow)
Set SumRange = .Range("U2:U" & LastRow)

End With

Sheets("data").Activate
Range("R1", "R" & LastRow).Select
Selection.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
Selection.Copy Sheets("output").Range("A20")
ActiveSheet.ShowAllData

Set CriteriaRange = Sheets("Output").Range("A21")
For r = 2 To Sheets("Output").Range("A21").End(xlDown).Row
Total = WorksheetFunction.SumIf(CodeRange, CriteriaRange,
SumRange)
CriteriaRange.Offset(0, 1) = Total
Set CriteriaRange = CriteriaRange.Offset(1, 0)
Next



With Sheets("Data")
LastRow = Sheets("Data").Range("R" & Rows.Count).End(xlUp).Row
Set CodeRange = .Range("R2:R" & LastRow)
Set SumRange = .Range("AC2:AC" & LastRow)

End With

Sheets("data").Activate
Range("R1", "R" & LastRow).Select
Selection.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
'Selection.Copy Sheets("output").Range("A1")
ActiveSheet.ShowAllData

Sheets("data").Activate
Range("AC1").Select
Selection.Copy Sheets("output").Range("C20")

Sheets("data").Activate
Range("U1").Select
Selection.Copy Sheets("output").Range("B20")


Set CriteriaRange = Sheets("Output").Range("A21")
For r = 2 To Sheets("Output").Range("A21").End(xlDown).Row
Total = WorksheetFunction.SumIf(CodeRange, CriteriaRange,
SumRange)
CriteriaRange.Offset(0, 2) = Total
Set CriteriaRange = CriteriaRange.Offset(1, 0)
Next


End Sub
 
J

joel

I made a lot of improvements in the code. I aslo wanted to put the summarry
sheet right after the data sheet so I changed the way the your for loop was
working. I need to move through the sheets from last to first so the sheets
got added properly.

I also made a check to see if new output sheet already exists so you don't
get duplicate sheet names and get errors. I clear the sheet if it already
exists.



Sub SummarySheet()

Dim ShDate As String

For ShCount = ThisWorkbook.Sheets.Count To 1 Step -1

Set sh = ThisWorkbook.Sheets(ShCount)
If UCase(Left(sh.Name, 4)) = "DATA" Then

ShDate = Trim(Mid(sh.Name, 5))
OutputShName = "Output " & ShDate
'check if sheet exists
found = False
For Each CheckSht In ThisWorkbook.Sheets
If CheckSht.Name = NewShtName Then
found = True
Exit For
End If
Next CheckSht

If found = False Then
'Create new worksheet
Set OutputSh = ThisWorkbook.Worksheets.Add(after:=sh)
OutputSh.Name = OutputShName
Else
Set OutputSh = Sheets(OutputShName)
'clear output sheet
OutputShName.Cells.ClearContents
End If
With sh
LastRow = .Range("R" & Rows.Count).End(xlUp).Row
Set CodeRange = .Range("R2:R" & LastRow)
Set SumRange = .Range("U2:U" & LastRow)

Set DataRange = .Range("R1", "R" & LastRow)
DataRange.AdvancedFilter _
Action:=xlFilterInPlace, _
Unique:=True
DataRange.Copy _
Destination:=OutputSh.Range("A20")
.ShowAllData
End With

With OutputSh
LastRow = .Range("A21").End(xlDown).Row
For RowCount = 21 To LastRow
Set CriteriaRange = .Range("A" & RowCount)
Total = WorksheetFunction.SumIf(CodeRange, CriteriaRange,
SumRange)
CriteriaRange.Offset(0, 1) = Total
Next RowCount
End With

With sh
LastRow = .Range("R" & Rows.Count).End(xlUp).Row
Set CodeRange = .Range("R2:R" & LastRow)
Set SumRange = .Range("AC2:AC" & LastRow)
.Range("R1", "R" & LastRow).AdvancedFilter _
Action:=xlFilterInPlace, _
Unique:=True

'Selection.Copy Sheets("output").Range("A1")
.ShowAllData
.Range("AC1").Copy _
Destination:=OutputSh.Range("C20")

.Range("U1").Copy _
Destination:=OutputSh.Range("B20")
End With

With Sheets("Output")
LastRow = .Range("A21").End(xlDown).Row
For RowCount = 21 To LastRow
Set CriteriaRange = .Range("A" & RowCount)
Total = WorksheetFunction.SumIf( _
CodeRange, CriteriaRange, SumRange)
CriteriaRange.Offset(0, 2) = Total
Next RowCount
End With
End If
Next ShCount
End Sub
 
J

joel

I made a lot of improvements in the code. I aslo wanted to put the summarry
sheet right after the data sheet so I changed the way the your for loop was
working. I need to move through the sheets from last to first so the sheets
got added properly.

I also made a check to see if new output sheet already exists so you don't
get duplicate sheet names and get errors. I clear the sheet if it already
exists.



Sub SummarySheet()

Dim ShDate As String

For ShCount = ThisWorkbook.Sheets.Count To 1 Step -1

Set sh = ThisWorkbook.Sheets(ShCount)
If UCase(Left(sh.Name, 4)) = "DATA" Then

ShDate = Trim(Mid(sh.Name, 5))
OutputShName = "Output " & ShDate
'check if sheet exists
found = False
For Each CheckSht In ThisWorkbook.Sheets
If CheckSht.Name = NewShtName Then
found = True
Exit For
End If
Next CheckSht

If found = False Then
'Create new worksheet
Set OutputSh = ThisWorkbook.Worksheets.Add(after:=sh)
OutputSh.Name = OutputShName
Else
Set OutputSh = Sheets(OutputShName)
'clear output sheet
OutputShName.Cells.ClearContents
End If
With sh
LastRow = .Range("R" & Rows.Count).End(xlUp).Row
Set CodeRange = .Range("R2:R" & LastRow)
Set SumRange = .Range("U2:U" & LastRow)

Set DataRange = .Range("R1", "R" & LastRow)
DataRange.AdvancedFilter _
Action:=xlFilterInPlace, _
Unique:=True
DataRange.Copy _
Destination:=OutputSh.Range("A20")
.ShowAllData
End With

With OutputSh
LastRow = .Range("A21").End(xlDown).Row
For RowCount = 21 To LastRow
Set CriteriaRange = .Range("A" & RowCount)
Total = WorksheetFunction.SumIf(CodeRange, CriteriaRange,
SumRange)
CriteriaRange.Offset(0, 1) = Total
Next RowCount
End With

With sh
LastRow = .Range("R" & Rows.Count).End(xlUp).Row
Set CodeRange = .Range("R2:R" & LastRow)
Set SumRange = .Range("AC2:AC" & LastRow)
.Range("R1", "R" & LastRow).AdvancedFilter _
Action:=xlFilterInPlace, _
Unique:=True

'Selection.Copy Sheets("output").Range("A1")
.ShowAllData
.Range("AC1").Copy _
Destination:=OutputSh.Range("C20")

.Range("U1").Copy _
Destination:=OutputSh.Range("B20")
End With

With Sheets("Output")
LastRow = .Range("A21").End(xlDown).Row
For RowCount = 21 To LastRow
Set CriteriaRange = .Range("A" & RowCount)
Total = WorksheetFunction.SumIf( _
CodeRange, CriteriaRange, SumRange)
CriteriaRange.Offset(0, 2) = Total
Next RowCount
End With
End If
Next ShCount
End Sub
 
J

joel

I made a lot of improvements in the code. I aslo wanted to put the summarry
sheet right after the data sheet so I changed the way the your for loop was
working. I need to move through the sheets from last to first so the sheets
got added properly.

I also made a check to see if new output sheet already exists so you don't
get duplicate sheet names and get errors. I clear the sheet if it already
exists.



Sub SummarySheet()

Dim ShDate As String

For ShCount = ThisWorkbook.Sheets.Count To 1 Step -1

Set sh = ThisWorkbook.Sheets(ShCount)
If UCase(Left(sh.Name, 4)) = "DATA" Then

ShDate = Trim(Mid(sh.Name, 5))
OutputShName = "Output " & ShDate
'check if sheet exists
found = False
For Each CheckSht In ThisWorkbook.Sheets
If CheckSht.Name = NewShtName Then
found = True
Exit For
End If
Next CheckSht

If found = False Then
'Create new worksheet
Set OutputSh = ThisWorkbook.Worksheets.Add(after:=sh)
OutputSh.Name = OutputShName
Else
Set OutputSh = Sheets(OutputShName)
'clear output sheet
OutputShName.Cells.ClearContents
End If
With sh
LastRow = .Range("R" & Rows.Count).End(xlUp).Row
Set CodeRange = .Range("R2:R" & LastRow)
Set SumRange = .Range("U2:U" & LastRow)

Set DataRange = .Range("R1", "R" & LastRow)
DataRange.AdvancedFilter _
Action:=xlFilterInPlace, _
Unique:=True
DataRange.Copy _
Destination:=OutputSh.Range("A20")
.ShowAllData
End With

With OutputSh
LastRow = .Range("A21").End(xlDown).Row
For RowCount = 21 To LastRow
Set CriteriaRange = .Range("A" & RowCount)
Total = WorksheetFunction.SumIf(CodeRange, CriteriaRange,
SumRange)
CriteriaRange.Offset(0, 1) = Total
Next RowCount
End With

With sh
LastRow = .Range("R" & Rows.Count).End(xlUp).Row
Set CodeRange = .Range("R2:R" & LastRow)
Set SumRange = .Range("AC2:AC" & LastRow)
.Range("R1", "R" & LastRow).AdvancedFilter _
Action:=xlFilterInPlace, _
Unique:=True

'Selection.Copy Sheets("output").Range("A1")
.ShowAllData
.Range("AC1").Copy _
Destination:=OutputSh.Range("C20")

.Range("U1").Copy _
Destination:=OutputSh.Range("B20")
End With

With Sheets("Output")
LastRow = .Range("A21").End(xlDown).Row
For RowCount = 21 To LastRow
Set CriteriaRange = .Range("A" & RowCount)
Total = WorksheetFunction.SumIf( _
CodeRange, CriteriaRange, SumRange)
CriteriaRange.Offset(0, 2) = Total
Next RowCount
End With
End If
Next ShCount
End Sub
 

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

Sorted data macro not working. Advice request... 3
VBA SUM Function 14
Sort and summarize code help request 1
Problems copy data when using filter in place 3
comment copy 3
vlookup issue 2
Macro for Multiple Worksheets 6
Type Mismatch 0

Top