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]

 

[jasonb75]

Hopefully I have this somewhere close to what you need.

From the information in earlier posts, I've assumed that the dates in the score sheets are in B54:B73. If not correct then this part will need changing.
I've also assumed from the original code that MonthlyMedal is the ActiveSheet and that this is the sheet where the results table is being collated.
Added an extra line which will enter then name of the sheet and the cell where the date was found into column K of the results table to assist with testing.
Finally, added a line to add the matchday date into A4, might need to change this slightly to allow for correct date formatting.

There are some comments in the code so that you can hopefully get an idea of what is going on.

Option Explicit
Sub MonthlyMedal()
With ActiveSheet
    .Unprotect Password:="xxxx" ' remove protection
Dim MatchDay As Date, calcState As Long, wksCurr As Worksheet, c As Range, rCount As Long
MatchDay = InputBox("Match Date Is") 'set date, anything that is not a valid date could cause an error
With Application
    calcState = .Calculation ' turn a few things off to speed things up a bit
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
End With

For Each wksCurr In ThisWorkbook.Worksheets ' loop through worksheets exlude any listed in the line below
    If Not (CBool(InStr(LCase("|Results|Lady_Players|Survey|Template|MonthlyMedal|"), LCase("|" & .Name & "|")))) Then
        For Each c In wksCurr.Range("B54:B73") ' loop through dates in column B
            If c = MatchDay Then ' matchday found
                .Range("B6").Offset(rCount) = wksCurr.Range("C1") ' copy name
                .Range("C6:H6").Offset(rCount) = Intersect(c.EntireRow, wksCurr.Range("Y:AD")) ' copy score data
                .Range("K6").Offset(rCount) = wksCurr.Name & " " & c.Address(0, 0) ' this line for testing only, identify where data found.
                rCount = rCount + 1 ' keep a count of how many rows have been added
            End If
        Next c
    End If
Next wksCurr
    .Range("A4") = MatchDay ' enter matchday date into A4
With Application
    .ScreenUpdating = True ' turn things back on again
    .Calculation = calcState
    .EnableEvents = True
End With
    .Protect Password:="xxxx" ' re-protect sheet
End With
End Sub

 

[dmt32]

MatchDay = InputBox("Match Date Is") 'set date, anything that is not a valid date could cause an error

Hi,
hope don't mind stepping in your post but you can avoid the Type Mismatch error (which would include cancel button being pressed) by making couple of changes to your code

Dim MatchDay As Variant
    Do
    MatchDay = InputBox("Match Date Is", "Enter Date")
'cancel pressed
    If StrPtr(MatchDay) = 0 Then Exit Sub
    Loop Until IsDate(MatchDay)
'corece to date
    MatchDay = DateValue(MatchDay)

'rest of code

Hope helpful

Dave

 

[jasonb75]

Thanks, Dave!

Step in and trample as much as you like (hopefully I won't regret saying that)

I did start with something similar (I used a few more lines with a Retry / Cancel messagebox for invalid dates, but aborted it to keep the code a bit simpler for testing.
Your method is more concise, I didn't test my code so expect it might need a copule of corrections later, I'll add your suggestion to it while I'm doing them.

 

[dmt32]

Most welcome – been following this thread & lot time & effort given to resolve for OP. All good stuff.

 

[Alemap]

Hi jasonb75, thanks for your input. I'm afraid I get an application-defined or object-defined error , which I believe to do with placing the MatchDay into "B4"?

Hope you had a good New Year

 

[jasonb75]

Did everything else work as expected?

I can't see that it should be, but if the error was placing the date into A4 then the rest of the data should still have been filled in before it failed.

Did you memeber to change "xxxx" to your proper password? (top and bottom of the code).

 

[Alemap]

No none of the data was filled before it failed ?So I put in the proper password and the code ran but only filled in the date - and then returned to the input box ,to start again.

 

[jasonb75]

Do you still have any of the old code lingering around?
I'm failing to see how it could loop back and start again otherwise unless you're running the code twice manually?? The inputbox is before any of the loops so there is no way for the code to go back and call it again automatically.

As a quick check on a couple of things, were my assumptions with the code correct? (see notes in bold in the post with the code).

Is the date coming out in the correct format? I can't remember the exact problem, but I did have an issue previously where vba was defaulting to US date format m/d/y which was not matching up to the UK format d/m/y dates in the sheet. Possibly there could be a similare issue here. This can be allowed for in the code, but it would need to be specific to your regional settings, so I would need to know what they are.

 

[GWteB]

I think I solved this puzzle (if so, then it's my first contribution in the MMXX decade on this board, at least where I live). Working with different Worksheet objects and Range objects can be rather difficult (in the past I've had much problems with it). Anyway, a made a few justifications to jasonb75 initial code, for the most significant part see below. The code takes action on the active worksheet (this can be changed), on which easily a FormButton can be placed; @Alemap I understand you can manage that yourself. If not, let me know. The code will not clear anything, however, overwriting it does. I've also added a dialog with some input checking just for convenience (and some unnecessary fun parts; btw "woensdag" will be Wednesday, my local system is Dutch).

This resulted in two modules, a regular one and a userform. Both depend on each other. The regular one consists of two procedures, one to launch the dialog and one to do the job as desired. Although the userform code is also on the board here, you can't use it. An existing userform consists of two files; one in ASCII and one in (kind of) binary. So the userform has to be imported. This can be done by right clicking on the project name in the left pane in the VBA editor; choose import file on the pop-up. Btw, the import dialog will show you just one of the two files: the .frm file will be seen but the .frx file is also needed (do not change filenames before importing). To be sure, make a copy of your scores workbook and import the two modules in that copy.

Module (regular)

Option Explicit

' for historical scores ,adjust this year as required
Public Const cMinYear           As Integer = 2018

Public Const cUsfCaption        As String = "Retrieving scores"
Public Const cErrAbort          As String = "Search not completed, terminated by user"
Public Const cErrDate           As String = "No such date exists!"
Public Const cMsgProcessing     As String = "Processing Worksheet $x$ of $z$"
Public Const cMsgWeekdayHist    As String = "This date fell on "
Public Const cMsgWeekdayFut     As String = "This date will fall on "

Public Const cMsgToday          As String = "That's today"

Public gbUsfDone                As Boolean
Public gbUsfAbort               As Boolean
Public gbSearchAborted          As Boolean
'

Public Sub LaunchSearchAndExtract()

    ' >> This is the MAIN procedure <<
    
    Dim usfMulti    As UserForm_GWteB
    Set usfMulti = New UserForm_GWteB
    
    usfMulti.SetScoreDestination ThisWorkbook.ActiveSheet
    usfMulti.Show
    Set usfMulti = Nothing
End Sub


Public Sub ExtractScores(ByRef argUsf As Object, ByRef argDestSht As Worksheet, ByVal argRequestedDate As Date)

    Dim CalcState       As XlCalculation
    Dim wksCurr         As Worksheet
    Dim rngCurr         As Range
    Dim rngScores       As Range
    Dim lRowCount       As Long
    Dim lShtCount       As Long
    Dim lShtCountInc    As Long

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

    ' loop through worksheets exlude any listed in the line below
    For Each wksCurr In ThisWorkbook.Worksheets
        If gbUsfAbort Then GoTo USER_ABORT
        lShtCount = ThisWorkbook.Worksheets.Count
        lShtCountInc = lShtCountInc + 1

'==== the most tricky part ====

        With wksCurr
            If Not (CBool(InStr(LCase("|Results|Lady_Players|Survey|Template|MonthlyMedal|"), LCase("|" & .Name & "|")))) Then
                For Each rngCurr In .Range("B54:B73")                                       ' loop through dates in column B
                    If rngCurr = argRequestedDate Then                                      ' matchday found
                        argDestSht.Range("B6").Offset(lRowCount) = .Range("C1")             ' copy name
                        Set rngScores = .Range("Y" & rngCurr.Row & ":AD" & rngCurr.Row)     ' rngScores points to score data
                        argDestSht.Range("C6:H6").Offset(lRowCount) = rngScores.Value       ' copy score data

        argDestSht.Range("K6").Offset(lRowCount) = .Name & " " & rngCurr.Address(0, 0)  ' >>>> this line for testing only, identify where data found.

                        lRowCount = lRowCount + 1                                           ' keep a count of how many rows have been added
                    End If
                Next rngCurr
            End If
        End With
        If Not argUsf Is Nothing Then
            argUsf.UpdateProgress lShtCountInc, lShtCount
        End If
        DoEvents
    Next wksCurr

' ==============================

    argDestSht.Range("A4") = argRequestedDate ' enter matchday date into A4

USER_ABORT:
    With Application
        .ScreenUpdating = True      ' turn things back on again
        .Calculation = CalcState
        .EnableEvents = True
    End With

    Set rngCurr = Nothing
    Set rngScores = Nothing
    Set wksCurr = Nothing
End Sub

Userform

Option Explicit

Private Const cBlack        As Long = &H80000012
Private Const cRed          As Long = &HFF&

Private dtRequestedDate     As Date
Private oWs                 As Worksheet
'


Public Sub SetScoreDestination(ByRef argDestSheet As Worksheet)
    If Not argDestSheet Is Nothing Then
        Set oWs = argDestSheet
    End If
End Sub


Public Sub UpdateProgress(ByVal argCount As Long, ByVal argTotal As Long)
    Dim strMsg  As String
    strMsg = Replace(cMsgProcessing, "$x$", CStr(argCount), , , vbTextCompare)
    strMsg = Replace(strMsg, "$z$", CStr(argTotal), , , vbTextCompare)
    Me.LbProcessing.Caption = strMsg
End Sub

Private Sub CboxDay_Change()
    Call CheckDate
End Sub
Private Sub CboxMonth_Change()
    Call CheckDate
End Sub
Private Sub CboxYear_Change()
    Call CheckDate
End Sub
Private Sub CbtnAbort_Click()
    gbUsfAbort = True
    Me.Hide
    Unload Me
End Sub
Private Sub CbtnDone_Click()
    gbUsfDone = True
    Me.Hide
    Unload Me
End Sub


Private Sub CbtnGO_Click()
    Me.CbtnGO.Enabled = False
    Call ExtractScores(Me, oWs, dtRequestedDate)
    If gbUsfAbort Then
        gbUsfDone = False
        MsgBox cErrAbort, vbExclamation, cUsfCaption
        Me.Hide
        Unload Me
    Else
        Me.CbtnDone.Visible = True
        Me.CbtnAbort.Visible = False
        Me.CbtnGO.Visible = False
    End If
End Sub


Private Sub UserForm_Initialize()
    gbUsfDone = False
    With Me
        .Caption = cUsfCaption
        .LbProcessing.Caption = ""
        .CbtnDone.Visible = False
        .CbtnDone.Top = 96
        .CbtnDone.Left = 138
        
        .CbtnGhost.ZOrder (1)
        .CbtnGhost.Height = .CbtnAbort.Height - 4
        .CbtnGhost.Top = .CbtnAbort.Top + 2
        .CbtnGhost.Left = .CbtnAbort.Left + 2
    End With
    Call Setup_DDMMYYYY

End Sub


Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    ' allow only the command buttons
    Cancel = True
End Sub


Private Sub Setup_DDMMYYYY()
    Dim n               As Integer
    Dim iDay            As Integer
    Dim iMonth          As Integer
    Dim iYear           As Integer
    iDay = Day(Now())
    iMonth = Month(Now())
    iYear = Year(Now())
    With Me.CboxDay
        .Value = iDay
        .ListRows = 31
        For n = 1 To 31
            .AddItem n
        Next
    End With
    With Me.CboxMonth
        .Value = iMonth
        .ListRows = 12
        For n = 1 To 12
            .AddItem n
        Next
    End With
    With Me.CboxYear
        .Value = iYear
        .ListRows = iYear - cMinYear + 1
        For n = cMinYear To iYear
            .AddItem n
        Next
    End With
End Sub



Private Function CheckDate() As Boolean

    Dim strPulledDate        As String

    With Me

        strPulledDate = .CboxDay.Text & "/" & _
                        .CboxMonth.Text & "/" & _
                        .CboxYear.Text
        
        On Error GoTo NON_DATE
        If IsDate(DateValue(strPulledDate)) Then
        
            On Error Resume Next
            ' setfocus raises an error when user blanks a DD/MM/YYYY combobox
            .CbtnGhost.SetFocus
            On Error GoTo 0

            .CbtnGO.Enabled = True
            .CboxDay.Font.Bold = False
            .CboxMonth.Font.Bold = False
            .CboxYear.Font.Bold = False
            .CboxDay.ForeColor = cBlack
            .CboxMonth.ForeColor = cBlack
            .CboxYear.ForeColor = cBlack
            If DateValue(Now()) = DateValue(strPulledDate) Then
                .LbProcessing.Caption = cMsgToday
            ElseIf DateValue(Now()) < DateValue(strPulledDate) Then
                .LbProcessing.Caption = cMsgWeekdayFut & WeekdayName(Weekday(DateValue(strPulledDate)))
            Else
                .LbProcessing.Caption = cMsgWeekdayHist & WeekdayName(Weekday(DateValue(strPulledDate)))
            End If
            dtRequestedDate = DateValue(strPulledDate)
        Else
NON_DATE:
            On Error GoTo 0
            .CbtnGO.Enabled = False
            .CboxDay.Font.Bold = True
            .CboxMonth.Font.Bold = True
            .CboxYear.Font.Bold = True
            .CboxDay.ForeColor = cRed
            .CboxMonth.ForeColor = cRed
            .CboxYear.ForeColor = cRed
            .LbProcessing.Caption = cErrDate

        End If
    End With
End Function

Both modules can be downloaded here WeTransfer

 

[Alemap]

Do you still have any of the old code lingering around?
I'm failing to see how it could loop back and start again otherwise unless you're running the code twice manually?? The inputbox is before any of the loops so there is no way for the code to go back and call it again automatically.

As a quick check on a couple of things, were my assumptions with the code correct? (see notes in bold in the post with the code).

Is the date coming out in the correct format? I can't remember the exact problem, but I did have an issue previously where vba was defaulting to US date format m/d/y which was not matching up to the UK format d/m/y dates in the sheet. Possibly there could be a similare issue here. This can be allowed for in the code, but it would need to be specific to your regional settings, so I would need to know what they are.

Hi jasonb75, i don't have any of the code interfering, your code was copied as is. A slight confusion on my part is that I gave you the impression that the code went back to the MsgBox - what I meant is that it completes and goes back to the start, without populating the Monthly Medal table.

OK so I enter the date in the MsgBox and then follow the code with 'F8" and it completes 12 or 13 iterations and arrives at the snip below.

All good so far, but there is nothing in the result table - from B6 (Name) or C6 : H6, or K6 and the Date has not been placed in "B3" yet (I changed A4 to B3 to suit my table). the next step places the date in B3 in the correct format.
Continuing with F8, the program continues to the end of the code and goes back to the start . No values have been placed in the table except the date.
So it has performed the loop though the sheets and within the table (Range B54:B73 ) to match the date, but has failed to retrieve any data from cols Y to AD including the names.

I am looking forward to this code performing as it appears to be very neat!

I hope you can crack it - it looks very close. Thank you
Your assumptions are quite correct and I did clarify to GWteB in my post # 20