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]
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]
