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
>
|
Similar Threads
