Excel VBA Gathering Names from a Schedule of People Working Today - vba

Question

Even though I thought this would be a common question, I have searched and can't seem to find an answer.
I have a work schedule and I'd like to search the today's date and return all the names of those who are scheduled to work today. I built a code that works but it takes a long time to complete and is not 100% effective every time its run. I am sure there must be a better and faster way to do this but I have not yet been able to find one. I have it broken apart into two different codes. The first one finds the column where today's date is located and the second one gathers the names and places them onto the next sheet.
Here's the First Sub:
Sub GetDateRow_()
'//////Finds the row that has today's date and returns the value of that row to cell C34\\\\\\
Dim SearchMe As Integer
SearchMe = Sheets("Sheet1").Range("C33")
Set FindMe = Sheets("Sheet1").Range("C5:AD5").Find(What:=SearchMe, LookIn:=xlValues, LookAt:= _
xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, SearchFormat:=False)
Sheets("Sheet1").Range("C34").Value = Cells(1, FindMe.Column)
End Sub
And the Second Sub:
Sub CopyScheduledToList()
'//////Searches Today's day Column from the schedule given by GetDateRow Sub & assimbles \\\\\\\
'////// the names of those who are scheduled to work today to a list on Page 2 \\\\\\\
Dim Ccount As Integer
Dim lngLoop As Long
Dim RowCount As Integer
Dim dShift As String
Dim cShift As String
Ccount = 1
dShift = "A63"
cShift = "TLA"
RowCount = Sheets("Sheet1").Range("C34").Value
lngLoop = 1
For lngLoop = 1 To Rows.count
If Cells(lngLoop, RowCount).Value = cShift Then Worksheets("Sheet2").Cells(1, 4).Value = Worksheets("Sheet1").Cells(lngLoop, 1).Value
'////// Get's the Team Leader and places name into column D on Page 2
If Cells(lngLoop, RowCount).Value = dShift Then Worksheets("Sheet2").Cells(Ccount, 1).Value = Worksheets("Sheet1").Cells(lngLoop, 1).Value
If Worksheets("Sheet2").Range("A" & Ccount).Value <> "" Then Ccount = Ccount + 1
'////// Places the name from the working list onto page 2 and adds a count so the next value found
'////// will go to the next empty row on Sheet 2
Next lngLoop
End Sub
Again, your help is greatly appreciated!

Answer 1

Your excessively long run times will be due to looping over 1048576 cells in your For lngLoop = 1 To Rows.count loop. That can be improved by just processing as far as the last cell that contains data in the applicable column.
The problem of it not always working correctly is almost certainly due to the fact that you have some Cells references which aren't qualified with the sheet that you want to use, and therefore they refer to the ActiveSheet.
Sub GetDateRow_()
'//////Finds the row that has today's date and returns the value of that row to cell C34\\\\\\
Dim SearchMe As Date
Dim FindMe As Range
With Worksheets("Sheet1")
SearchMe = .Range("C33").Value
Set FindMe = .Range("C5:AD5").Find(What:=SearchMe, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If FindMe Is Nothing Then
MsgBox "Date not found!"
Else
'I think this line
'.Range("C34").Value = .Cells(1, FindMe.Column).Value
'should be
.Range("C34").Value = FindMe.Column
'so that it saves the column number you want
End If
End With
End Sub
Sub CopyScheduledToList()
'//////Searches Today's day Column from the schedule given by GetDateRow Sub & assembles \\\\\\\
'////// the names of those who are scheduled to work today to a list on Page 2 \\\\\\\
Dim Ccount As Integer
Dim lngLoop As Long
Dim TodaysCol As Long
Dim dShift As String
Dim cShift As String
Dim lastRow As Long
Dim wsSrc As Worksheet
Dim wsDst As Worksheet
Ccount = 1
dShift = "A63"
cShift = "TLA"
Set wsSrc = Worksheets("Sheet1")
Set wsDst = Worksheets("Sheet2")
TodaysCol = wsSrc.Range("C34").Value
'Find last used row in today's column
lastRow = wsSrc.Cells(wsSrc.Rows.Count, TodaysCol).End(xlUp).Row
For lngLoop = 1 To lastRow
If wsSrc.Cells(lngLoop, TodaysCol).Value = cShift Then
wsDst.Cells(1, "D").Value = wsSrc.Cells(lngLoop, "A").Value
End If
'////// Get's the Team Leader and places name into column D on Page 2
If wsSrc.Cells(lngLoop, TodaysCol).Value = dShift Then
If wsSrc.Cells(lngLoop, "A").Value <> "" Then
wsDst.Cells(Ccount, "A").Value = wsSrc.Cells(lngLoop, "A").Value
Ccount = Ccount + 1
End If
End If
'////// Places the name from the working list onto page 2 and adds a count so the next value found
'////// will go to the next empty row on Sheet 2
Next lngLoop
End Sub

Answer 2

Your first sub is, in fact, a function (or should be) which returns a value which can be assigned to a variable in your second sub. The following code realises that concept. It is different in other respects too, but I think you will like it. Please try.
Option Explicit
Sub CopyScheduledToList()
'//////Searches Today's day Column from the schedule given by GetDateRow Sub & assambles \\\\\\\
'////// the names of those who are scheduled to work today to a list on Page 2 \\\\\\\
' it is best practise, not to have any hard-coded addresses in the code.
' Therefore it is good to place all parameters separate from and before the code:
Const SearchRow As Long = 5
Const dShift As String = "A63"
Const cShift As String = "TLA"
Dim WsMain As Worksheet ' better to set your own variable
Dim WsOutput As Worksheet ' even if it will be "ActiveSheet"
Dim TgtColumn As Long
Dim Rlast As Long ' last data row in WsMain
Dim Rcount As Long ' output row counter
Dim R As Long
Set WsMain = ActiveSheet ' might be Sheets("Sheet1")
Set WsOutput = Worksheets("Sheet2") ' or, simply, Sheet1
TgtColumn = DateColumn(WsMain, SearchRow)
If TgtColumn < 1 Then Exit Sub
Rcount = 1
With WsMain
Rlast = .Cells(.Rows.Count, TgtColumn).End(xlUp).Row
For R = 1 To Rlast
Select Case .Cells(R, TgtColumn).value
Case cShift
'////// Get's the Team Leader and places name into column D on WsOutput
WsOutput.Cells(Rcount, "D").value = .Cells(R, 1).value
Case dShift
WsOutput.Cells(Rcount, "A").value = .Cells(R, 1).value
Case Else
Exit Sub ' define the correct response if neither is found
End Select
If Len(WsOutput.Cells(Rcount, "A").value) Then Rcount = Rcount + 1
'////// Places the name from the working list onto page 2 and adds a count so the next value found
'////// will go to the next empty row on Sheet 2
Next R
End With
End Sub
Private Function DateColumn(Ws As Worksheet, _
ByVal SearchRow As Long) As Long
' returns the row that has today's date
' return 0 if not found
Dim SearchMe As Variant
Dim TgtDate As String
Dim Fnd As Range
If SearchRow < 1 Then Exit Function
Do
TgtDate = InputBox("Enter the target date", _
"List shift workers", _
Format(Date, "Short Date"))
' you can also set the default like Format(Date + 1, "d/m/yy")
' the sample date format must match your regional settings
If IsDate(TgtDate) Then
SearchMe = CDate(TgtDate)
' SearchMe will have the date in the format set
' in your regional settings
Exit Do
Else
MsgBox "Please enter a valid date" & vbCr & _
"in d-m-yy format", vbExclamation, "Invalid date"
' adjust the required format to your regional settings
End If
Loop While Len(TgtDate) ' enter blank or press Cancel to exit
Set Fnd = Ws.Rows(SearchRow).Find(What:=SearchMe, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
If Not Fnd Is Nothing Then DateColumn = Fnd.Column
End Function