Loop through all sheets, calculate Average in K1 of each sheet

[ryguy7272]

Mid afternoon; got into the office early and still not fully awake here. I
am trying to loop through all sheets and fine the average for numbers in a
range, which always starts in J2 (has a header) and goes down a variable
number of rows. I want to enter the average in Cell K1. This is what I have
so far.

Sub Aver()
Dim lastrow As Long

For Each sh In Worksheets
If (sh.Name) <> "Summary Sheet" And (sh.Name) <> "Alpha" And (sh.Name)
<> "PSA Time Interval" And (sh.Name) <> "Summary" Then
sh.Activate


With sh
lastrow = .Cells(.Rows.Count, "J").End(xlUp).Row
.Cells(lastrow, "K").Activate
'ActiveCell.Offset(0, 0).Select
Selection.End(xlUp).Select
ActiveCell.FormulaR1C1 = "=average(r2c" & lastrow
End With

End If
Next sh

End Sub

My macro is trying to calculate the average in column K, but I want to base
the average on Column J. Please help.

TIA,
Ryan---

 

[Mauro Gamberini]

Public Sub m()

On Error GoTo ErrorHandler

Dim mSheetsArray As Sheets
Dim sh As Worksheet

With Application
.ScreenUpdating = False
.Calculation = xlManual
.StatusBar = "Sub m()"
End With

Set mSheetsArray = _
Worksheets(Array("Sheet1", "Sheet3"))

For Each sh In mSheetsArray
With sh
.Range("K1").Value = _
"=AVERAGE(" & _
.Range("J2").CurrentRegion.Address _
& ")"
End With
Next

ExitRow:
Set sh = Nothing
Set mSheetsArray = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
.StatusBar = ""
End With
Exit Sub

ErrorHandler:
MsgBox Err.Number & vbNewLine & Err.Description
Resume ExitRow

End Sub


Or:

Public Sub m()

On Error GoTo ErrorHandler

Dim sh As Worksheet
Dim lLastRow As Long

With Application
.ScreenUpdating = False
.Calculation = xlManual
.StatusBar = "Sub m()"
End With

For Each sh In Worksheets

With sh
If .Name <> "Summary Sheet" And _
.Name <> "Alpha" And _
.Name <> "PSA Time Interval" _
And .Name <> "Summary" Then

lLastRow = _
.Range("J" & Rows.Count).End(xlUp).Row
.Range("K1").Value = _
"=AVERAGE(" & _
"J2:j" & lLastRow _
& ")"
End If
End With

Next

ExitRow:
Set sh = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
.StatusBar = ""
End With
Exit Sub

ErrorHandler:
MsgBox Err.Number & vbNewLine & Err.Description
Resume ExitRow

End Sub

 

[RyanH]

You do not need some of the code you have. I made some changes to what you
already have. This code should run faster and not have screen flickering.

Sub Aver()

Dim LastRow As Long

For Each sh In Worksheets
With sh
If .Name <> "Summary Sheet" And _
.Name <> "Alpha" And _
.Name <> "PSA Time Interval" And _
.Name <> "Summary Sheet" Then

LastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
.Cells(LastRow, "K").Formula = "=AVERAGE(J2:J & LastRow)"
End If
End With
Next sh

End Sub

 

[RyanH]

Oops! Change this line

..Cells(LastRow, "K").Formula = "=AVERAGE(J2:J & LastRow)"

with this

..Cells(LastRow, "K").Value = WorksheetFunction.Average(Range("J2:J" &
LastRow))

 

[ryguy7272]

Thanks Mario! The second sub worked for me; the first did not...too many
sheets perhaps. One more thing. How can I list all results in one summary
sheet? I have macro that lists all tab names in a book, but I modified it
slightly, to ignore the three sheets that serve as my template, but now it
doesn't list any sheets!

Sub ListSheets()
'list of sheet names starting at A1
Dim rng As Range
Dim i As Integer
Dim sh As Worksheet

If .Name <> "Alpha" And _
.Name <> "PSA Time Interval" _
And .Name <> "Summary" Then

For Each sh In Worksheets
With sh


Set rng = Range("A1")
For Each Sheet In ActiveWorkbook.Sheets
rng.Offset(i, 0).Value = Sheet.Name
i = i + 1
Next Sheet
End With
Next sh
End If

End Sub

The error is on this line:
If .Name <> "Alpha" And _

It reads 'invalid or unqualified reference'.
I need to resolve this error and then list each K1 in each sheet so that the
tab names listed in the 'Summary Sheet' are related to the averages in K1 in
each sheet.


Thanks,
Ryan---

 

[RyanH]

The If...Then Statement must be in the With Statement. Your current
If...Then is look for a reference to an object and it isn't there, thus a
error occurs. In your case you need a worksheet object, which is your 'sh'
variable. I made the correction for you below. You will need to change the
sheet name where the list will go. I currently have it set as "SheetName".

What line did you get an error in my first post? What did the error say?

'list of sheet names starting at A1
Sub ListSheets()

Dim sh As Worksheet

For Each sh In Worksheets
With sh
If .Name <> "Alpha" And _
.Name <> "PSA Time Interval" And _
.Name <> "Summary" Then

' list sheet names in SheetName worksheet
Sheets("SheetName").Cells(i, "A").Value = .Name
i = i + 1
End If
End With
Next sh

End Sub

 

[RyanH]

Correction! Use this code.

'list of sheet names starting at A1
Sub ListSheets()

Dim sh As Worksheet
Dim i As Long

i = 1
For Each sh In Worksheets
With sh
If .Name <> "Alpha" And _
.Name <> "PSA Time Interval" And _
.Name <> "Summary" Then

' list sheet names in SheetName worksheet
Sheets("SheetName").Cells(i, "A").Value = .Name
i = i + 1
End If
End With
Next sh

End Sub

 

[ryguy7272]

This is not pretty, but it is quite fast, and it does exactly what I need it
to do.

Sub ListSheets()
Sheets("Summary Sheet").Select

Dim I As Long, sh As Worksheet
Dim bWrite As Boolean
bWrite = False
I = 3
For Each sh In Worksheets

If (sh.Name) <> "Summary Sheet" Then
If (sh.Name) <> "Alpha" Then
If (sh.Name) <> "PSA Time Interval" Then
If (sh.Name) <> "Summary" Then


Worksheets("Summary Sheet").Cells(I, "a").Value = sh.Name
I = I + 1

Else
bWrite = False
End If
End If
End If
End If

Next sh

Call ListData10

End Sub


Sub ListData10()
Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range

Set rDest = ActiveWorkbook.Worksheets("Summary Sheet").Range("B3")
For Each sh In ActiveWorkbook.Worksheets


If (sh.Name) <> "Summary Sheet" Then
If (sh.Name) <> "Alpha" Then
If (sh.Name) <> "PSA Time Interval" Then
If (sh.Name) <> "Summary" Then

rDest.Offset(0, -1).Value = sh.Name
With sh.Range("K1")
rDest.Resize(1, .Columns.Count).Value = .Value
End With
Set rDest = rDest.Offset(1, 0)

End If
End If
End If
End If
Next sh

Columns("A:B").Select
Columns("A:B").EntireColumn.AutoFit
Range("A1").Select
End Sub


Thanks to everyone who got involved!!!

Regards,
Ryan---

 

[Mauro Gamberini]

Thanks Mario!

Mauro

How can I list all results in one summary
sheet?

In Summary Sheet?

Public Sub m()

On Error GoTo ErrorHandler

Dim sh As Worksheet
Dim shSummary As Worksheet
Dim lLastRow As Long
Dim lLastRowSumm As Long

With Application
.ScreenUpdating = False
.Calculation = xlManual
.StatusBar = "Sub m()"
End With

Set shSummary = Worksheets("Summary Sheet")

For Each sh In Worksheets

With sh
If .Name <> "Summary Sheet" And _
.Name <> "Alpha" And _
.Name <> "PSA Time Interval" _
And .Name <> "Summary" Then

lLastRow = _
.Range("J" & Rows.Count).End(xlUp).Row
.Range("K1").Value = _
"=AVERAGE(" & _
"J2:j" & lLastRow _
& ")"
lLastRowSumm = _
shSummary.Range("A" & Rows.Count).End(xlUp).Row + 1
shSummary.Range("A" & lLastRowSumm).Value = .Name
shSummary.Range("B" & lLastRowSumm).Value = _
"=AVERAGE(" & .Name & _
"!J2:j" & lLastRow _
& ")"
'or
' shSummary.Range("B" & lLastRowSumm).Value = _
' "=(" & .Name & "!K1" & ")"
End If
End With

Next

ExitRow:
Set sh = Nothing
Set shSummary = Nothing
With Application
.ScreenUpdating = True
.Calculation = xlAutomatic
.StatusBar = ""
End With
Exit Sub

ErrorHandler:
MsgBox Err.Number & vbNewLine & Err.Description
Resume ExitRow

End Sub

 

[RyanH]

I realize you have your code working now, but there a number of things in
your code that don't really make sense to do.

1.) You declared a Boolean variable bWrite in your Sub ListSheets that never
equals True. I don't see the reason to even declare it. Although in this
sub it doesn't make any noticable performance issue it actually is.

2.) Your multiple If...Then Statements are not needed. Your code will
actually run faster with the With...End With Statement. You may notice
because you code is kinda short, but it does give you better performance
using the With Statement when using the same object.

3.) Here is the code that I would suggest using which would actually run
faster.

Sub ListSheets()

Dim I As Long
Dim sh As Worksheet
Dim bWrite As Boolean

bWrite = False

Sheets("Summary Sheet").Select

I = 3
For Each sh In Worksheets
With sh
If .Name <> "Summary Sheet" And _
.Name <> "Alpha" And _
.Name <> "PSA Time Interval" And _
.Name <> "Summary" Then
Sheets("Summary Sheet").Cells(I, "A").Value = .Name
I = I + 1
Else
bWrite = False
End If
End With
Next sh

Call ListData10

End Sub

Sub ListData10()

Dim ws As Worksheet
Dim rCopy As Range
Dim rDest As Range

Set rDest = ActiveWorkbook.Worksheets("Summary Sheet").Range("B3")
For Each sh In Worksheets
With sh
If .Name <> "Summary Sheet" And _
.Name <> "Alpha" And _
.Name <> "PSA Time Interval" And _
.Name <> "Summary" Then

With rDest
.Offset(0, -1).Value = .Name
.Resize(1, .Columns.Count).Value = .Range("K1").Value
Set rDest = .Offset(1, 0)
End With
End If
End With
Next sh

Columns("A:B").EntireColumn.AutoFit
Range("A1").Select

End Sub