Macro for Multiple Worksheets

[Excel Hates Me]

Excel 2003

I am trying to create a macro to perform several functions on each
worksheet within a workbook. The worksheet names are not static. I
have put together a macro (thanks to everyone whose code I borrowed
from various posts) but it only runs on the current sheet. The
remaining sheets are unaffected. Could someone please tell me what I
am doing wrong? I'm going crazy. Thanks for the help.

-----

Sub AllSheetFunctions()

' select all sheets
Dim myArray() As Variant
Dim i As Integer
For i = 1 To Sheets.count
ReDim Preserve myArray(i - 1)
myArray(i - 1) = i
Next i
Sheets(myArray).Select

' begin repeat for all worksheets
Dim ws As Worksheet
Set MySheets = ActiveWindow.SelectedSheets
For Each ws In MySheets

' Autofit
Range("A1").Select
Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
Selection.Columns.autofit

' Go to next blank row in Column G
Range("G1").End(xlDown).Offset(1, 0).Select

' Bold cell and add text
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Count"

' Move one cell to right and bold
Selection.Offset(0, 1).Select
Selection.Font.Bold = True

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

' Move eight cells to right, bold and add text
Selection.Offset(0, 8).Select
Selection.Font.Bold = True
ActiveCell.FormulaR1C1 = "Totals"

' Move one cell to right, bold, and add formula to blank cell
at bottom of column
Selection.Offset(0, 1).Select
Selection.Font.Bold = True
LastRow = Range("Q65536").End(xlUp).Row + 1
Cells(LastRow, 17).Formula = "=SUM(Q2:Q" & LastRow - 1 & ")"

Next ws

' end repeat for all worksheets

End Sub

 

[ManicMiner17]

On 15/07/2010 02:19, Excel Hates Me wrote:

Hi EHM,

For a quick and dirty fix you could put ws.select after "For Each ws in
MySheets".

However the code would benefit from being re-written to avoid using
select statements.

I'm sure someone here will provide that code!

Rgds,

MM

 

[Dave Peterson]

I'm not sure if this does what you want, so test it first!

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
.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 With

Next ws

End Sub

 

[Excel Hates Me]

THANK YOU!
THANK YOU!
Worked like a charm. I am receiving a circular reference box but it
doesn't seem to affect anything. I will try to figure out how you did
that Much appreciated!

 

[Dave Peterson]

Check out the formulas that were added. I think they're including the cells
with the formula. And that can't be right.

Maybe the formulas need to be adjusted--that LastRow may not be what you expect.

 

[Excel Hates Me]

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.Copy _
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]

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