Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > Apply maco to multiple worksheets request
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 111
Default Apply maco to multiple worksheets request
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
Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 9,101
Default Apply maco to multiple worksheets request
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







"joecrabtree" wrote:

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

Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 9,101
Default Apply maco to multiple worksheets request
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







"joecrabtree" wrote:

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

Reply With QuoteReply With Quote
  #4   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 9,101
Default Apply maco to multiple worksheets request
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







"joecrabtree" wrote:

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

Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
How to apply macro across multiple worksheets within a workbook murkaboris Excel Discussion (Misc queries) 4 April 9th 09 01:24 AM
Need to apply VBA code to multiple Worksheets parteegolfer Excel Programming 2 March 12th 06 08:43 PM
Apply Macro on Multiple Worksheets in a Workbook Agnes Excel Programming 0 September 24th 04 01:39 AM
Apply Macro on Multiple Worksheets in a Workbook Agnes Excel Programming 1 September 23rd 04 02:20 AM
Apply Macro on Multiple Worksheets in a Workbook Agnes Excel Programming 1 September 22nd 04 11:42 PM


All times are GMT +1. The time now is 06:14 AM.

Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
Copyright ©2004-2025 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement