Looping through sheets and retrieving data from specific cells

[Alemap]

Good Day everyone, I'm trying to loop through many sheets in a workbook and retrieve data from a table array of size A54:AD73 on a particular date and post the values into a table array in a results sheet. (see table below)
The values to be collected against a Name, which is in cell C1 of every sheet, will be in columns Y to AD in the row with the date, which could be in different rows for each sheet. The date if it has been entered, resides in Column B of every sheet.

I Have being trying to combine code that I already have that loops through all sheets and retrieves summary data from the same cells of each sheet.

The code below runs but it only retrieves data from row B54 in which I entered the date for each sheet for testing but am unable to proceed with looping throgh the sheets, match the date and post the data in the results sheet

[VBA Code]
Sub MonthlyMedal()


ActiveSheet.Unprotect Password:="xxxx"
Dim i As Long
Dim j As Long
Dim MatchDay As Date
Dim Lastrow As Long

Dim wksMonthlyMedal As Worksheet
Dim wksCurr As Worksheet
Dim arrData() As Variant
Dim intRow As Integer
'MatchDay = InputBox("Match Date Is")
MatchDay = "19/01/19"


intRow = 0
ReDim arrData(1 To ThisWorkbook.Worksheets.Count - 1, 1 To 7)

Set wksResults = ThisWorkbook.Worksheets("Results")
Set wksLady_Players = ThisWorkbook.Worksheets("Lady_Players")
Set wksSurvey = ThisWorkbook.Worksheets("Survey")
Set wksTemplate = ThisWorkbook.Worksheets("Template")
Set wksMonthlyMedal = ThisWorkbook.Worksheets("MonthlyMedal")

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



For Each wksCurr In ThisWorkbook.Worksheets

If wksCurr.Name <> wksResults.Name _
And wksCurr.Name <> wksLady_Players.Name _
And wksCurr.Name <> wksSurvey.Name _
And wksCurr.Name <> wksMonthlyMedal.Name _
And wksCurr.Name <> wksTemplate.Name Then


'For j = 54 To 56
' If wksCurr.Range(j, "B") = MatchDay Then
' MsgBox ActiveWorkbook.Worksheets(i).Cells(j, "B").Value
' MsgBox wksCurr.Range(j, "B").Value
' Next
'Lastrow = Lastrow + 1
'End If
'
intRow = intRow + 1
arrData(intRow, 1) = wksCurr.Range("C1") 'B Name
arrData(intRow, 2) = wksCurr.Range("Y54") 'C Score 1
arrData(intRow, 3) = wksCurr.Range("Z54") 'D Score 2
arrData(intRow, 4) = wksCurr.Range("AA54")'E Score 3
arrData(intRow, 5) = wksCurr.Range("AB54") 'F Score 4
arrData(intRow, 6) = wksCurr.Range("AC54") 'G Putts
arrData(intRow, 7) = wksCurr.Range("AD54") 'H Division
'

End If
Next wksCurr
wksMonthlyMedal.Range("B5").Resize(UBound(arrData), UBound(arrData, 2)) = arrData
Set wksCurr = Nothing
Set wksMonthlyMedal = Nothing

Application.ScreenUpdating = screenUpdateState
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.Protect Password:="7410", DrawingObjects:=True, Contents:=True, Scenarios:=True


End Sub [/Code]

 

[Alemap]

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim KeyCells As Range
Set KeyCells = Range("L5")
Call MonthlyMedal

End Sub

@GWteB, I really appreciate the time spent on my project. I understand your comments and advice.
The code above is indeed in the Worksheet module of the MonthlyMedal worksheet and the code statement

Dim KeyCells As Range, Set KeyCells = Range("L5")

was simply taken off the internet, without understanding the relevance to be honest.
I think your suggestion of a table is a brilliant one, however I have failed to unlock the column headings for sorting, no matter how I set the protected ranges even selecting "Sort" on the protection dropdown list,
I will keep trying but that is partly why my reply has been so late.
I have noted all your other comments/suggestions - Thank you

 

[GWteB]

... however I have failed to unlock the column headings for sorting, no matter how I set the protected ranges even selecting "Sort" on the protection dropdown list,

Besides checking the appropriate check boxes when protecting your worksheet there is something else that has to be done to make sorting possible on a protected worksheet. The range involved in the sorting has to be defined seperatly. On the ribbon, Review tab, is a button named "Allow Users to Edit Ranges". The selected range has to be given a name followed by Apply/OK (in addition users on your local system or network can be given special permissions, but you may omit that). I have taken this into account in my code below.

The code above is indeed in the Worksheet module of the MonthlyMedal worksheet and the code statement

OK then, I overlooked something (again... ). Somewhere at the start of your "search & fetch" sub, Events are being disabled (and turned on afterwards), so an endless loop will not occur, however ...
every time you edit your worksheet your "search & fetch" Sub is called. Even when the chosen date (the matchday) is not changed, the names and scores from the approx 150 sheets will be obtained, regardless what cell is involved and every time you'll end up with a protected sheet. To circumvent that behaviour you can test (in your code) wether the cell with the date (from the dropdown) is changed or not. When the Worksheet_Change event occurs, Excel passes the changed Cell (or area) on to the Worksheet_Change Sub by the variable named "Target" ...
Private Sub Worksheet_Change(ByVal Target As Range)
... so this variable can be used in further action, for example when changes occur in a cell of which we want to monitor the change of (and we will ...). Since "Target" has a property called "Parent" (pointing to the worksheet on which the Cell or area is on) we're also sure about the sheet on wich we take our desired actions on, provided we take the right measures in our code.
So Excel passes in many situations variables on to subs that handle events, we can do the same in our code. I make use of this option in many cases. The following is not only an example, it can be placed in de code module of the MonthlyMedal sheet. This way you have the advantage that you can mark the single code line as a comment to (temporarily) disable the "search & fetch" Sub.

Private Sub Worksheet_Change(ByVal Target As Range)

    ' pass on target to the called Sub
    Call MonthlyMedal(argTarget:=Target)

End Sub

Below the code of a Sub to TEST the "search & fetch" and the sub that is called by Worksheet_Change every time a change occurs. Finally, a modified version of the search & fetch sub as of your post #41 code. The modifications are:
1. The cell addresses are declared as global string constants. They are referring to cells you mentioned in previous posts. Only the names of these constants appear in various places in the code and after compilation (and during run-time) VBA will replace those names with their linked values. In this way it's more easy to adapt the code to the layout of the sheet, just by changing these strings (still there are limitations ...).

2. Sheet protection with the ability to sort name and score columns with the use of AutoFilter; sorting by Excel without VBA code.

Put the code below (together) in a regular module

Option Explicit
    
' >> necessary global declarations <<
    
' relevant Ranges on ALL SOURCE sheets
Public Const cStrNameFieldOnAllScoreSheets                  As String = "C1"
Public Const cStrDateRangeOnAllScoreSheets                  As String = "B54:B73"
Public Const cStrScoreColumnsOnAllScoreSheets               As String = "Y:AD"
    
' relevant Ranges on the DESTINATION sheet
Public Const cStrMatchDayFromDropDownOnDestinationSheet     As String = "L3"
Public Const cStrRequestedDateFieldOnDestinationSheet       As String = "B3"
Public Const cstrHeadingsAreaOnDestinationSheet             As String = "B3:H3"
Public Const cStrNameColumnAndStartRowOnDestinationSheet    As String = "B4"
Public Const cStrScoreColumnsAndStartRowOnDestinationSheet  As String = "C4:H4"
'


Private Sub TEST_MonthlyMedal()
    Dim dtMyDate    As Date
    
    dtMyDate = #11/5/2019#
    
    Call ExtractScores_v2(ThisWorkbook.ActiveSheet, dtMyDate)
End Sub


Public Sub MonthlyMedal(ByRef argTarget As Range)

    ' this sub is called by the Worksheet_Change event of the MonthlyMedal worksheet

    Dim dtMyDate    As Date

    ' if the cell according to above constant "cStrMatchDayFromDropDownOnDestinationSheet"
    ' is changed there's some work to do, else not
    If argTarget.Address = Range(cStrMatchDayFromDropDownOnDestinationSheet).Address Then
        ' get the chosen date
        dtMyDate = argTarget.Value
        ' another sub is doing the job, so pass on the right sheet and the chosen date
        Call ExtractScores_v2(argTarget.Parent, dtMyDate)
    End If
End Sub


Private Sub ExtractScores_v2(ByRef argDestSht As Worksheet, ByVal argRequestedDate As Date)

    ' necessary local declarations
    Dim oAER            As AllowEditRange
    Dim calcState       As XlCalculation
    Dim wksCurr         As Worksheet
    Dim rngCurr         As Range
    Dim rngScores       As Range
    Dim rngUsed         As Range
    Dim lRowCount       As Long
    Dim vScoreCols      As Variant

    ' turn a few things off to speed things up a bit
    With Application
        calcState = .Calculation
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With

    With argDestSht
        .Unprotect Password:="Y_O_U_R____P_A_S_S_W_O_R_D"
    
        ' if AutoFilter is turned on, turn it off
        If .AutoFilterMode Then
            .Range(cStrNameColumnAndStartRowOnDestinationSheet).AutoFilter
        End If
    End With

    ' determine area filled with names and scores of a certain date
    Set rngUsed = GetRangeOfNamesAndScores(argDestSht, argHeadingsIncluded:=False)
'rngUsed.Select   ' <<<< uncomment this line to see (in debug mode using F8) what range we're working on

    ' we do'n want scores from another date to be left behind, so ...
    ' >>>>> CLEAR THAT AREA <<< (but only when another date (from dropdown) is chosen)
    rngUsed.ClearContents

    vScoreCols = Split(cStrScoreColumnsOnAllScoreSheets, ":")

' ===========================================================================================================
    ' THIS PART IS BASED ON JASONB75's CODE and modified for using global declared constants

    ' loop through worksheets exclude any listed in the line below
    For Each wksCurr In ThisWorkbook.Worksheets
        With wksCurr
            If Not (CBool(InStr(LCase("|Results|Lady_Players|Survey|Template|MonthlyMedal|"), LCase("|" & .Name & "|")))) Then
                ' loop through all dates
                For Each rngCurr In .Range(cStrDateRangeOnAllScoreSheets)
                    If rngCurr = argRequestedDate Then
                        ' if matchday found do the following
                        ' copy player name
                        argDestSht.Range(cStrNameColumnAndStartRowOnDestinationSheet).Offset(lRowCount) = .Range(cStrNameFieldOnAllScoreSheets)
                        ' rngScores points to score data on players score sheet
                        Set rngScores = .Range(vScoreCols(0) & rngCurr.Row & ":" & vScoreCols(1) & rngCurr.Row)
                        ' copy score data
                        argDestSht.Range(cStrScoreColumnsAndStartRowOnDestinationSheet).Offset(lRowCount) = rngScores.Value
                        ' keep track of how many rows have been added
                        lRowCount = lRowCount + 1
                    End If
                Next rngCurr
            End If
        End With
        DoEvents
    Next wksCurr
' ===========================================================================================================

    With argDestSht

        ' show matchday date (pulled by dropdown) elsewhere on sheet (when required)
        .Range(cStrRequestedDateFieldOnDestinationSheet) = argRequestedDate
        ' if AutoFilter is turned off, turn it on again on the right headings
        If Not .AutoFilterMode Then
            .Range(cstrHeadingsAreaOnDestinationSheet).AutoFilter
        End If
        ' >>> decide which area may undergo sorting (and filtering) <<<
        ' delete the names of the present areas because
        ' area may have more rows then before or less rows then before
        For Each oAER In .Protection.AllowEditRanges
            oAER.Delete
        Next
        ' determine area filled with new names and new scores on a new certain date
        Set rngUsed = GetRangeOfNamesAndScores(argDestSht, argHeadingsIncluded:=True)
'rngUsed.Select   ' <<<< uncomment this line to see (in debug mode using F8) what range we're working on

        ' protect worksheet and be able to sort (and filter) names and scores
        .Protection.AllowEditRanges.Add Title:="NamesAndScores", Range:=rngUsed
        .EnableSelection = xlUnlockedCells
        .Protect Password:="Y_O_U_R____P_A_S_S_W_O_R_D", DrawingObjects:=True, Contents:=True, Scenarios:=True, _
                                                         AllowSorting:=True, AllowFiltering:=True
    End With

    ' turn things back on again
    With Application
        .ScreenUpdating = True
        .Calculation = calcState
        .EnableEvents = True
    End With

    ' clean up
    Set rngUsed = Nothing
    Set rngCurr = Nothing
    Set rngScores = Nothing
    Set wksCurr = Nothing
End Sub


Private Function GetRangeOfNamesAndScores(ByRef argSht As Worksheet, ByVal argHeadingsIncluded As Boolean) As Range

    ' === this Function is called by ExtractScores_v2 TWICE ===
    ' In order to be able:
    '  1. clearing the contents within the range with names and scores
    '     before putting new names and scores of another date on the sheet
    '  2. to add that range to the AllowEditRanges collection for
    '     sorting (and filtering) on a protected sheet

    Dim vTmp    As Variant
    Dim rngTmp  As Range

    ' get first (and last) cell name on headings area (as string)
    ' (we only need the first cell at this point, store it in vTmp(0))
    vTmp = Split(cstrHeadingsAreaOnDestinationSheet, ":")
    ' determine area filled with headings, names and scores
    With argSht
        Set rngTmp = Intersect(Range(.Range(cstrHeadingsAreaOnDestinationSheet), .Cells(.Rows.Count, .Range(vTmp(0)).Column)), .UsedRange)
    End With
    ' return desired range as passed on by the 2nd boolean var
    If argHeadingsIncluded Then
        ' fit for sorting and filtering
        Set GetRangeOfNamesAndScores = rngTmp
    Else
        ' leave headings intact, so shift one row downwards en resize (minus 1 row)
        ' fit for clearing contents
        Set GetRangeOfNamesAndScores = rngTmp.Resize(rngTmp.Rows.Count - 1, rngTmp.Columns.Count).Offset(1, 0)
    End If
    Set rngTmp = Nothing
End Function

In combination with the sub MonthlyMedal (which is called by the sub Worksheet_Change) you can - after removing the protection manually - edit your sheet. It will stay unprotected until the value in the cell which is linked to the date dropdown and in the code is declared as Public Const cStrMatchDayFromDropDownOnDestinationSheet As String = "L3" changes, then your sheet will be protected again.
Because I don't like repetitive code, I wrote a separate Function which is called by the "search & fetch" Sub twice. Between the code lines I've put some explanation.
When you make a copy of the MonthlyMedal worksheet and when you make this sheet the active sheet you can test the above code with the sub TEST_MonthlyMedal, wether or not using F8 key to run the code step by step. Before testing do change the dtMyDate variable with a date of which you are sure that it will exist on (one of) the 150 score sheets.
Hopefully with this info and / or code you can go one step further with your project.

 

[Alemap]

Thank you GWteB once again for your un-flagging patience! Your code has ventured into unchartered waters for me now. The Workbook is going live on the 18th and is working faultlessly at the moment. I have reverted to the dropdown list to trigger the looping, "search&fetch" sub that you guys put together for me. I am using the form control buttons for sorting the columns of the results and have put aside the use of a table for the results, for now, because of the difficulty I had to unprotect the data for sorting - which you have addressed above. I have therefore saved the code and will try to incorporate it at a later date during the season when I'm not pressed for time.
Thank you and jasonb75 for your expert help. Much appreciated.

 

[GWteB]

You are welcome! Glad that you're having a Workbook now that suits your needs. I wish you a nice and successful tournament. Thanks for letting me know. Cheers.