Microsoft Excel - Macro to loop through a number of spreadsheets and sum a particular cell in each sheet

I have 240 named sheets. Each sheet is named with a Golfer's name and contains the results of their golf scores captured weekly whenever the course is played by the members. The members sheets are generated at the beginning of the year, and the scores are captured and summarised in a Results Sheet at the end of the Workbook. All this I developed with the invaluable help of one of your experts - Wally eye.

I need to sum the score for each hole (1 to 18), across the entire book (+- 240 sheets) so I require a Macro to loop through the sheets and add the scores of each hole from each player, totalled in a corresponding cell, in a Table, at the end of the book. 

I have already totalled the score for each hole, for each player in a table on their individual sheets. So the Macro would pick up each players total for a particular hole from this table on each players sheet. viz:

The total for each player will be found in Cells D109: L109 for the first 9 holes and N109: V109 for the holes 10 to 18 on each sheet.

So the Macro should start looping from the first Players Sheet which is the Third Sheet of the book to the last named sheet and sum the scores in the 'Results' sheet in cells D260:L260 for holes 1 to 9 and cells N260:V260 for holes 10 to 18.

The first sheets are Members, Results and Template, so the macro  should begin with the first named sheet omitting these sheets.

Thankyou

Paddy

Hello Paddy,

You sound like a man after my own heart.

Try this.

Option Explicit
Sub Summary()

Dim wb As Workbook
Dim ws As Worksheet
Dim rngSummary1 As Range, rngSummary2 As Range, cell As Range
Dim intCount As Integer

Set wb = ThisWorkbook
Set rngSummary1 = wb.Worksheets("Results").Range("D260")
Set rngSummary2 = wb.Worksheets("Results").Range("N260")
rngSummary1.Resize(1, 9).Value = 0
rngSummary2.Resize(1, 9).Value = 0


For Each ws In Worksheets
If ws.Name <> "Members" And ws.Name <> "Template" And ws.Name <> "Results" Then
    For intCount = 0 To 8
      rngSummary1.Offset(0, intCount).Value = rngSummary1.Offset(0, intCount).Value + ws.Range("D109").Offset(0, intCount).Value
      rngSummary2.Offset(0, intCount).Value = rngSummary2.Offset(0, intCount).Value + ws.Range("N109").Offset(0, intCount).Value
    Next intCount
End If
Next ws

End Sub

Regards
Harry

Hi Harry,
That was brilliant, thank you so much, it worked first time, after a couple of changes to the tables this side. 
Now I will expand it a bit to include another course in the same worksheet.
I will revert if I run into trouble if you don't mind?
Thank you
Regards
Paddy

Not a problem Paddy,
May all your putts be short ones.
Harry

Hi Harry, The code runs very well I had adapted it to suit my sheets and table, in fact I inserted a separate sheet for the results of the 'survey'.
I am surprised how slowly it completes the iterations, one can almost see it looping through the sheets? I tested it against the SUM function eg SUM('First named sheet:Last named sheet'!AF113), etc for each of the 18 holes, and the result was almost instantaneous.
I would appreciate if you could look at my code to see if there is something that maybe slowing it down. Maybe it is simply the number of loops involved that appears to make it so slow. I make that 250 x 18 x 2 = 9000 loops??
Please find the code for the first golf course. I am collecting total shots and total rounds viz shots is range C7 and M7 and rounds C8 and M8.


Option Explicit


Private Sub TotalShotsCrs1()

'Course 1 Survey - MECC Ladies Cumulated Rounds and Shots Course 1 2014

ActiveSheet.Unprotect
Dim wb As Workbook
Dim ws As Worksheet
Dim rngSummary1 As Range, rngSummary2 As Range, rngSummary3 As Range, rngSummary4 As Range, cell As Range
Dim intCount As Integer

Set wb = ThisWorkbook
Set rngSummary1 = wb.Worksheets("Survey").Range("C7")
Set rngSummary2 = wb.Worksheets("Survey").Range("M7")
Set rngSummary3 = wb.Worksheets("Survey").Range("C8")
Set rngSummary4 = wb.Worksheets("Survey").Range("M8")

rngSummary1.Resize(1, 9).Value = 0
rngSummary2.Resize(1, 9).Value = 0
rngSummary3.Resize(1, 9).Value = 0
rngSummary4.Resize(1, 9).Value = 0



For Each ws In Worksheets
If ws.Name <> "Lady_Players" And ws.Name <> "Results" And ws.Name <> "Template" And ws.Name <> "Survey" Then
    For intCount = 0 To 8
      rngSummary1.Offset(0, intCount).Value = rngSummary1.Offset(0, intCount).Value + ws.Range("D113").Offset(0, intCount).Value
      rngSummary2.Offset(0, intCount).Value = rngSummary2.Offset(0, intCount).Value + ws.Range("N113").Offset(0, intCount).Value
      rngSummary3.Offset(0, intCount).Value = rngSummary3.Offset(0, intCount).Value + ws.Range("D114").Offset(0, intCount).Value
      rngSummary4.Offset(0, intCount).Value = rngSummary4.Offset(0, intCount).Value + ws.Range("N114").Offset(0, intCount).Value
    Next intCount
End If
Next ws
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub

Hi Paddy,
Try inserting this at the start

Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False

  and this at the end of the macro

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

Arguably there should also be some sort of error trapping so that if the macro fails for some reason you don't get caught with all of the functionality turned off but for a trial you should see whether it improves the situation and we can deal with the other later.
Regards
Harry 

Hi Harry, Fantastic. Thank you so much that has made an incredible difference to the speed of the processing. I have read up a bit about optimizing VBA so as to understand what is happening in the background. I will look at the other code that I am using in the workbook to see if these refinements will be appropriate?
You mentioned 'error' trapping? Do you think I should pursue this as a precaution, even though the macro is running beautifully?? If so I would be grateful if you instruct me as to how I go about it?
I am so chuffed with this code - thank you again.
Kind regards
Paddy

Hello Paddy,

A typical macro to deal with this situation would look something like this

Sub typical()
screenUpdateState = Application.ScreenUpdating
calcState = Application.Calculation
eventsState = Application.EnableEvents

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

On Error GoTo leaveGracefully

CODE<>

Application.ScreenUpdating = screenUpdateState
Application.Calculation = calcState
Application.EnableEvents = eventsState

Exit Sub

leaveGracefully:
Application.ScreenUpdating = screenUpdateState
Application.Calculation = calcState
Application.EnableEvents = eventsState

End Sub

The reason that it is done like this is to record the state of the parameters in case they are different from 'standard' and then restore them to that state when the CODE finishes and exits via the Exit Sub.  However, if there was an error during the running of CODE and the macro stopped then the workbook would be left in limbo with the functionality turned off.  While not impossible to recover manually, it is not something that you would want to do or expect someone else to do.  So the error trapping directs the macro to continue from the address given and restores the parameters to their original state.
You could also provide messages to indicate what the error was and so forth but this might not be necessary in this case but could be useful for trouble-shooting if failures ever did occur.
Regards
Harry

Hi Paddy,
Just realised that I missed a bit in my last reply.  The tail end of the code should look like this.

finishJob:
Exit Sub

leaveGracefully:
Application.ScreenUpdating = screenUpdateState
Application.Calculation = calcState
Application.EnableEvents = eventsState

Resume finishJob

End Sub

Regards
Harry

Hello Harry,
Thank you for your additional piece. I have been working on the error handling and the code works fine but it looks a bit messy, as I am still a novice! and I don't know what would happen if it encountered an error? In addition I don't understand where your 'end piece' of code - finishjob slots in?

This is what I have at the moment. Your help will be appreciated.

Rgs Paddy

Private Sub Temp1Survey()

'Course 1 Survey - MECC Ladies Cumulated Rounds and Shots Course 1 2014

Dim screenUpdateState
Dim calcState
Dim eventsState

'check functionality status

screenUpdateState = Application.ScreenUpdating
calcState = Application.Calculation
eventsState = Application.EnableEvents

'turn off screen updating to stop flicker & increase speed
'turn off automatic recalculating mode
'turn off events processing

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

On Error GoTo leaveGracefully

ActiveSheet.Unprotect
Dim wb As Workbook
Dim ws As Worksheet
Dim rngSummary1 As Range, rngSummary2 As Range, rngSummary3 As Range, rngSummary4 As Range, cell As Range
Dim intCount As Integer

Set wb = ThisWorkbook
Set rngSummary1 = wb.Worksheets("Survey").Range("C7")
Set rngSummary2 = wb.Worksheets("Survey").Range("M7")
Set rngSummary3 = wb.Worksheets("Survey").Range("C8")
Set rngSummary4 = wb.Worksheets("Survey").Range("M8")

rngSummary1.Resize(1, 9).Value = 0
rngSummary2.Resize(1, 9).Value = 0
rngSummary3.Resize(1, 9).Value = 0
rngSummary4.Resize(1, 9).Value = 0

    
For Each ws In Worksheets
 If ws.Name <> "Lady_Players" And ws.Name <> "Results" And ws.Name <> "Template" And ws.Name <> "Survey" Then
    For intCount = 0 To 8
      rngSummary1.Offset(0, intCount).Value = rngSummary1.Offset(0, intCount).Value + ws.Range("D113").Offset(0, intCount).Value
      rngSummary2.Offset(0, intCount).Value = rngSummary2.Offset(0, intCount).Value + ws.Range("N113").Offset(0, intCount).Value
      rngSummary3.Offset(0, intCount).Value = rngSummary3.Offset(0, intCount).Value + ws.Range("D114").Offset(0, intCount).Value
      rngSummary4.Offset(0, intCount).Value = rngSummary4.Offset(0, intCount).Value + ws.Range("N114").Offset(0, intCount).Value
    Next intCount
 End If

Next ws

Application.ScreenUpdating = screenUpdateState
Application.Calculation = calcState
Application.EnableEvents = eventsState

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True


Exit Sub

leaveGracefully:

'reinstate functionality

Application.ScreenUpdating = screenUpdateState
Application.Calculation = calcState
Application.EnableEvents = eventsState

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

End Sub

   
   
'finishJob:
'Exit Sub

'leaveGracefully:
'Application.ScreenUpdating = screenUpdateState
'Application.Calculation = calcState
'Application.EnableEvents = eventsState

'Resume finishJob

'End Sub

Hi Paddy,
Sorry the second post was a bit obtuse.  Basically if the code strikes an error of any sort the macro diverts to the leave gracefully section.  The Resume tell it to continue running after that which really only exits the macro.  If it didn't do that the macro would just stop and not finish.

Private Sub Temp1Survey()

'Course 1 Survey - MECC Ladies Cumulated Rounds and Shots Course 1 2014

Dim screenUpdateState
Dim calcState
Dim eventsState

'check functionality status

screenUpdateState = Application.ScreenUpdating
calcState = Application.Calculation
eventsState = Application.EnableEvents

'turn off screen updating to stop flicker & increase speed
'turn off automatic recalculating mode
'turn off events processing

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

On Error GoTo leaveGracefully

ActiveSheet.Unprotect
Dim wb As Workbook
Dim ws As Worksheet
Dim rngSummary1 As Range, rngSummary2 As Range, rngSummary3 As Range, rngSummary4 As Range, cell As Range
Dim intCount As Integer

Set wb = ThisWorkbook
Set rngSummary1 = wb.Worksheets("Survey").Range("C7")
Set rngSummary2 = wb.Worksheets("Survey").Range("M7")
Set rngSummary3 = wb.Worksheets("Survey").Range("C8")
Set rngSummary4 = wb.Worksheets("Survey").Range("M8")

rngSummary1.Resize(1, 9).Value = 0
rngSummary2.Resize(1, 9).Value = 0
rngSummary3.Resize(1, 9).Value = 0
rngSummary4.Resize(1, 9).Value = 0

    
For Each ws In Worksheets
 If ws.Name <> "Lady_Players" And ws.Name <> "Results" And ws.Name <> "Template" And ws.Name <> "Survey" Then
    For intCount = 0 To 8
      rngSummary1.Offset(0, intCount).Value = rngSummary1.Offset(0, intCount).Value + ws.Range("D113").Offset(0, intCount).Value
      rngSummary2.Offset(0, intCount).Value = rngSummary2.Offset(0, intCount).Value + ws.Range("N113").Offset(0, intCount).Value
      rngSummary3.Offset(0, intCount).Value = rngSummary3.Offset(0, intCount).Value + ws.Range("D114").Offset(0, intCount).Value
      rngSummary4.Offset(0, intCount).Value = rngSummary4.Offset(0, intCount).Value + ws.Range("N114").Offset(0, intCount).Value
    Next intCount
 End If

Next ws

Application.ScreenUpdating = screenUpdateState
Application.Calculation = calcState
Application.EnableEvents = eventsState

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True


finishJob:
Exit Sub

leaveGracefully:

'reinstate functionality

Application.ScreenUpdating = screenUpdateState
Application.Calculation = calcState
Application.EnableEvents = eventsState

ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

Resume finishJob

End Sub

   
   Regards

Harry

Hi Harry, 
Thank you for your prompt response. I will insert the last bit of code and that should complete the story.
Thank you for your help.
Kind regards
Paddy