View Single Post
  #7   Report Post  
Posted to microsoft.public.excel.programming
Dave Peterson[_2_] Dave Peterson[_2_] is offline
external usenet poster
 
Posts: 420
Default Macro for Multiple Worksheets

You could add another check in the other code that looks to see what's been used
in each sheet before continuing:

Option Explicit
Sub AllSheetFunctions()

Dim ws As Worksheet
Dim NextCell As Range
Dim LastRow As Long

'why select all the sheets first?
'Worksheets.Select
'For Each ws In ActiveWindow.SelectedSheets

' begin repeat for all worksheets
For Each ws In ActiveWorkbook.Worksheets
With ws
If .UsedRange.Address = "$A$1" Then
'skip it
Else
'do the work
.UsedRange.Columns.AutoFit

Set NextCell = .Cells(.Rows.Count, "G").End(xlUp).Offset(1, 0)

' Bold cell and add text
With NextCell
.Font.Bold = True
.Value = "Count"

.Offset(0, 1).Font.Bold = True
End With

' Add formula to blank cell at bottom of column 8
LastRow = .Cells(.Rows.Count, "H").End(xlUp).Row + 1
.Cells(LastRow, 8).Formula = "=COUNTA(H2:H" & LastRow - 1 & ")"

' Move eight cells to right, bold and add text
With .Cells(LastRow, 16)
.Font.Bold = True
.FormulaR1C1 = "Totals"
End With

With .Cells(LastRow, 17)
.Font.Bold = True
.Formula = "=SUM(Q2:Q" & LastRow - 1 & ")"
End With
End If
End With

Next ws

End Sub


On 07/15/2010 20:59, Excel Hates Me wrote:
Found it. The macro that breaks out my data to multiple tabs creates
an additional blank sheet at the end, called (e.g.) Sheet11. So I end
up with a circular reference on that sheet when I run the next macro
(above). Not sure if there is something I can do to edit the code or a
macro to delete the blank sheet.

Sub BreakoutTabs()
' delete top 3 rows
Rows("2:5").Select
Range("A3").Activate
Selection.Delete Shift:=xlUp
Range("A1").Select

' format worksheet
Selection.AutoFormat Format:=xlRangeAutoFormatList3, Number:=True,
Font:= _
True, Alignment:=True, Border:=True, Pattern:=True,
Width:=True

' begin breakout
Dim strSrcSheet As String
Dim rngSrcStart As Range
Dim rngSrcEnd As Range
Dim rngCell As Range
Dim strLastDept As String
Dim intDestRow As Integer

On Error GoTo ErrHnd

'name of source data worksheet (tab)
strSrcSheet = "SrcData"

With ActiveWorkbook
'setup source range in column D
Set rngSrcStart = .Worksheets(strSrcSheet).Range("D2")
Set rngSrcEnd = .Worksheets(strSrcSheet).Range("D65534").End(xlUp)

'set destination row counter
intDestRow = 1
'set last department name
strLastDept = ""

'loop through cells in column D
For Each rngCell In Range(rngSrcStart, rngSrcEnd)
'test if policy info change
If rngCell.Text< strLastDept Then
'create new sheet
.Worksheets.Add After:=.Worksheets(Worksheets.count)
'name new sheet
.Worksheets(Worksheets.count).Name = rngCell.Text
'copy header row
.Worksheets(strSrcSheet).Range("A1").EntireRow.Cop y _
Destination:=.Worksheets(rngCell.Text).Range("A1")
'reset variables
strLastDept = rngCell.Text
intDestRow = 1

End If
'copy entire row
rngCell.EntireRow.Copy _

Destination:=.Worksheets(strLastDept).Range("A1"). Offset(intDestRow,
0)
'increment row counter
intDestRow = intDestRow + 1
Next rngCell

End With
Exit Sub
'error handler
ErrHnd:
Err.Clear
End Sub


--
Dave Peterson