VBA No Cells are found [duplicate] - excel

This question already has answers here:
Handle "No cells were found" error when filtered range is empty
(4 answers)
Closed 9 months ago.
I used this yesterday and it ran fine but today I got a error "Run-time error '1004': No cells were found.
It bugs at
Range("A6:A30").SpecialCells(xlCellTypeVisible).Find("Temp").Select
Attached Macro Below
Sub HrsInput()
' Disable screen updating.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Dim workbooks and sheet names.
Dim WB1, WB2 As Workbook, Year As String
Set WB1 = ActiveWorkbook
Year = Mid(ActiveSheet.Name, 10, 4)
' Copy-n-paste raw reports.
Dim FSO As Object, SourcePath As String, DestinPath As String
Set FSO = CreateObject("Scripting.FileSystemObject")
SourcePath = "\\ONTWSFS003\share\MIRALOMA\Brian\Raw Reports (FM)\*.xls"
DestinPath = "\\ONTWSFS003\share\MIRALOMA\Brian\"
FSO.CopyFile SourcePath, DestinPath
' Repeat below process until encountering an error.
Dim FileCount As Integer
Filename = Dir(SourcePath)
Do While Filename <> ""
FileCount = FileCount + 1
Filename = Dir()
Loop
For FileNum = 1 To FileCount
' Open raw report.
Workbooks.Open Filename:= _
"\\ONTWSFS003\share\MIRALOMA\Brian\*.xls"
' Capture raw report and total hours.
Set WB2 = ActiveWorkbook
Dim TotalOT As Double, BUNum As String, ReportDate() As String, WeekNum As Integer, ColNum As Integer
BUNum = Left(Range("A5"), 7)
ReportDate = Split(Range("A7"), " ")
WeekNum = WorksheetFunction.WeekNum(ReportDate(4))
Range("A:Q").UnMerge
' If not OT then skip the file.
If Not Range("A14:Z14").Find("OT1.5") Is Nothing Then
Range("A14:Z14").Find("OT1.5").Select
ColNum = Selection.Column
Range("A15:A300").Find("total").Select
Selection.Offset(0, ColNum - 1).Select
TotalOT = Selection.Value
' Fill out job title if empty.
Dim EmptyJobRng As Range, EmptyJobCell As Range
Set EmptyJobRng = Range("C15:C150").SpecialCells(xlCellTypeBlanks)
For Each EmptyJobCell In EmptyJobRng.Cells
If EmptyJobCell.Offset(0, 2) <> "" Then
EmptyJobCell = EmptyJobCell.Offset(-1, 0)
End If
Next EmptyJobCell
' Filter by temp only.
If Not Range("C15:C100").Find("*") Is Nothing Then
With Range("C14:Y150")
.AutoFilter field:=3, Criteria1:="<>"
.AutoFilter field:=1, Criteria1:="*Temp"
End With
End If
' Calculate total temp OT hours.
Dim TotalTempOT As Double, OT As Range
TotalTempOT = 0
Range("A14:Z14").Find("OT1.5").Select
Selection.Offset(1, 0).Select
Selection.Resize(150, 1).Select
Set OT = Selection.SpecialCells(xlCellTypeVisible)
For Each TempOT In OT.Cells
TotalTempOT = TotalTempOT + TempOT
Next TempOT
' Filter by BU and blank rows.
WB1.Activate
With Range("A5:BD30")
.AutoFilter field:=2, Criteria1:=BUNum
.AutoFilter field:=WeekNum + 2, Criteria1:="="
End With
' Locate temp row and week column to paste total temp OT hours.
Range("A6:A30").SpecialCells(xlCellTypeVisible).Find("Temp").Select
Selection.Offset(0, WeekNum + 1).Select
Selection = TotalTempOT
' Locate CEVA row and week column to paste total CEVA OT hours (total OT - total temp OT).
Range("A6:A109").SpecialCells(xlCellTypeVisible).Find("CEVA").Select
Selection.Offset(0, WeekNum + 1).Select
Selection = TotalOT - TotalTempOT
' Clear filters.
Sheets("Tracking " & Year & " (by BU)").ShowAllData
End If
' Delete current raw report.
WB2.Activate
ActiveWorkbook.Saved = True
ActiveWorkbook.ChangeFileAccess xlReadOnly
Kill ActiveWorkbook.FullName
WB2.Close
WB1.Activate
Next FileNum
' Update week number and weekly total OT hours.
' Week number
Range("A4").Offset(0, WeekNum).Select
Selection.Copy
Selection.Offset(0, 1).Select
Selection.PasteSpecial (xlPasteFormulas)
' Report date
Range("A5").Offset(0, WeekNum + 1).Select
Selection = "WE" & ReportDate(4)
' Weekly total OT hours
Range("A110").Offset(0, WeekNum).Select
Selection.Copy
Selection.Offset(0, 1).Select
Selection.PasteSpecial (xlPasteFormulas)
' Format Painter to new column
Range("B:B").Select
Selection.Offset(0, WeekNum - 1).Select
Selection.Copy
Selection.Offset(0, 1).Select
Selection.PasteSpecial (xlPasteFormats)
Sheets("Tracking " & Year & " (by Loc)").Select
Range("A:A").Select
Selection.Offset(0, WeekNum - 1).Select
Selection.Copy
Selection.Offset(0, 1).Select
Selection.PasteSpecial (xlPasteFormats)
' Notification when complete.
MsgBox "Data imported successfully.", vbOKOnly, "Complete"
' Enable screen updating.
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub

SpecialCells(xlCellTypeVisible) raises a run-time error if there are no visible cells - one option is to ignore that error:
Dim f As range
'...
Set f = Nothing
On Error Resume Next 'ignore error if no visible cells
Set f = Range("A6:A30").SpecialCells(xlCellTypeVisible).Find("Temp")
On Error Goto 0 'stop ignoring errors
If Not f Is Nothing then
'do something with f
Else
'No visible cells, or no visible "Temp" cell...
End If
'...

Related

Excel VBA Timeline slicerChache doesnt work with data from power query

I have a code where Pivot timeline date is changing based on the date.
Previously I had an sheet with data, but recently change the data source to from power query.
My error is that Timeline slicer doesn't work anymore.
Does anyone know why this error can occure?
ERROR : Run-time error '5' :
Invalid procedure call or argument.
Sub Datos_nustatymas()
Dim wb As Workbook, ws As Worksheet
Dim Lastrow As Long, i As Long, r As Long
Dim dt As Date, dtLast As Date, newdays As Long
Application.ScreenUpdating = False
Application.EnableEvents = False
Set wb = ThisWorkbook
wb.RefreshAll ' Refresh Pivot '
Set ws = wb.Sheets("Report")
With ws
' find end of existing data in B
Lastrow = .Cells(.Rows.Count, "B").End(xlUp).Row
' calc number of days to yesterday
dtLast = .Range("A" & Lastrow).Value2
newdays = Date - 1 - dtLast
If newdays < 1 Then
MsgBox "Report is up to date", vbExclamation
Exit Sub
Else
' extend column A to yesterday
With .Range("A" & Lastrow + 1).Resize(newdays)
.Formula = "=R[-1]C+1"
.Value = .Value
End With
End If
'update column B
For i = 1 To newdays
r = Lastrow + i
dt = .Cells(r, "A")
' this code selects a timeline date
ActiveWorkbook.SlicerCaches("NativeTimeline_VALUE_DATE").TimelineState. _
SetFilterDateRange dt, dt
' Copy/Paste details from Pivot to celected cells'
.Range("O4:Z4").Copy
.Cells(r, "B").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Next
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox newdays & " days added", vbInformation
End Sub```
Fixed. Just changed "NativeTimeline_VALUE_DATE" to "Timeline_VALUE_DATE" and it worked.

Streamlining deleting rows containing dates within a range specified by another cell

I delete rows based on the date in a column.
The dataset is around 85,000 rows and the macro can take from 30s to 5m+ with constant freezing.
I'm not sure if this is due to poorly written code or the size of the dataset.
Sub DeleteCurrentPeriod()
Dim ws As Worksheet
Application.ScreenUpdating = False
Set ws = ThisWorkbook.Worksheets("Transaction list by date")
ws.Activate
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
'Insert column, autofill formula for range
Sheets("Transaction list by date").Select
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
ActiveCell.FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Selection.AutoFill Destination:=Range("AR2:AR100000"), Type:=xlFillDefault
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$100000").AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$100000").SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
You can give this a try (use F8 key to run it step by step)
Some suggestions:
Name your procedure and variables to something meaningful
Indent your code (you may use Rubberduckvba.com)
Split the logic in steps
Read about avoiding select and activate here
Code:
Public Sub DeleteCurrentPeriod()
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim transactionSheet As Worksheet
Set transactionSheet = ThisWorkbook.Worksheets("Transaction list by date")
' Turn off autofilter and show all data
transactionSheet.AutoFilterMode = False
' Find last row
Dim lastRow As Long
lastRow = transactionSheet.Cells(transactionSheet.Rows.Count, "AQ").End(xlUp).Row
' Define range to be filtered
Dim targetRange As Range
Set targetRange = transactionSheet.Range("A1:BE" & lastRow)
' Insert column
transactionSheet.Columns("AR:AR").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
' Add formula & calculate
transactionSheet.Range("AR2:AR" & lastRow).FormulaR1C1 = "=IFERROR(IF(RC[-1]>CONTROL!R20C7,""Y"",""""),"""")"
Application.Calculate
'Filter on new column for cells matching criteria
transactionSheet.Range("A1:BE" & lastRow).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
transactionSheet.Range("A2:BE" & lastRow).SpecialCells(xlCellTypeVisible).EntireRow.Delete
'Delete added column and remove filter
transactionSheet.Columns("AR:AR").Delete Shift:=xlToLeft
' Remove filter
transactionSheet.AutoFilterMode = False
'Select A1
Range("A1").Select
CleanExit:
' Turn on stuff again
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Exit Sub
CleanFail:
MsgBox "An error occurred:" & Err.Description
GoTo CleanExit
End Sub
Let me know if it works
I've just made a couple of changes to how you work out the last row and how you do the calculation, it looks like you were comparing to a constant on the Control sheet. I wonder though why are you adding a column in and then deleting it, could you not just perform the calcs in column +1 after your data? Then you wouldn't have to create and delete the column.
'Insert column, autofill formula for range
Dim x as Long, y, lastrow
Sheets("Transaction list by date").Select
'Find the last row used
With Sheets("Transaction list by date")
lastrow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
Columns("AR:AR").Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("AR2").Select
' Get the constant and perform the comparison, add "Y" to TRUE cells
x= Worksheets("Control").Cells(20,7).value
For y = 1 to lastrow
If Worksheets("Transaction list by date").Cells(y,44)>x then _
Worksheets("Transaction list by date").Cells(y,44).value = "Y"
Next y
'Filter on new column for cells matching criteria
ws.Range("$A$1:$BE$" & lastrow ).AutoFilter Field:=44, Criteria1:="Y"
'Delete rows with matching criteria
On Error Resume Next
Application.DisplayAlerts = False
ws.Range("$A$2:$BE$" & lastrow).SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
On Error GoTo 0
'Delete added column and remove filter
Columns("AR:AR").Select
Selection.Delete Shift:=xlToLeft
On Error Resume Next
ws.ShowAllData
On Error GoTo 0
Application.ScreenUpdating = True
Application.Goto Reference:=Range("A1")
End Sub
Sub RemoveDups()
Const COMPARE_COL As Long = 1
Dim a, aNew(), nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim v As String, tmp
a = Worksheets("Sheet1").UsedRange
nr = UBound(a, 1)
nc = UBound(a, 2)
ReDim aNew(1 To nr, 1 To nc)
rNew = 0
v = Date
For r = 1 To nr
tmp = a(r, COMPARE_COL)
If tmp <> v Then
rNew = rNew + 1
For c = 1 To nc
aNew(rNew, c) = a(r, c)
Next c
v = tmp
End If
Next r
Worksheets("Sheet1").UsedRange = aNew
End Sub
This is an answer written by Tim Williams I just set the range to used range and set v to Date, so if you copy and paste this it will search based on the current date you run the macro looking through column 1 (A) If you want to use a different date you'll have to redefine v, you can make that equal to the cell on your control sheet. Took 1 second to "delete" 85000 rows.

Function call results in type 13 mismatch

So close to completing a large project but cant seem to get past this mismatch. Any help would be appreciated. Hoping this is not too much info...
Getting an .xlsx single sheet file and need to add information to the data in a new book using a cross reference table to get business dates and periods. Here is a sample of the source book:
Sample data snippet
I got this code from #PGSystemTester as a vlookup solution to pull data off of a reference table using a date which would fall between dates in separate columns on the reference table.
Function rngLOOKUP(chkDate As Date, rngf As Range, theColumn As Long) As Variant
Dim acell As Range
For Each acell In rngf.Columns(1).Cells
If acell.Value <= chkDate And acell.Offset(0, 1).Value >= chkDate Then
rngLOOKUP = acell.Offset(0, theColumn - 1).Value
Exit Function
End If
Next acell
rngLOOKUP = "#Nothing"
End Function
I have searched and tried dozens of methods to format the date but cannot get past a type mismatch and am starting to wonder if it is actually the date that is the issue:
Here is a sample of the cross reference table:
Cross reference table sample
Each time I use this call to assign the result to a variable I get a run time error 13, type mismatch:
fYear = rngLOOKUP(aDate, rng, 3)
Here is the complete code. The source file is .xlsx and I format the cell the date comes from before assigning it to a variable.
Sub CleanDaily_Labour()
'
' CleanDaily_Labour Macro
' RMDC Payroll Resarch (MU) Report prep
'
Dim myPath, fName, refFILE, job, JobGR, DateST, WKDay, PDWK, fYear As String
Dim CRef, wkb As Workbook
Dim shtDATE, shtJOB, sht As Worksheet
Dim aDate, fYR As Date
Dim rngLOOKUP As Variant
Dim rng, rngJOBS, rngJBGRP As Range
Dim SC, lastRow, PD, WK As Long
Application.ScreenUpdating = False
myPath = Application.ActiveWorkbook.Path
'
' Get the file date and assign to variables
'
Range("D3").Select
Selection.NumberFormat = "yyyy-mm-dd"
aDate = Range("D3").Value
DateST = WorksheetFunction.Text(aDate, "YYYYMMDD")
WKDay = WorksheetFunction.Text(aDate, "DDD")
Selection.Copy
Range("D7").Select
ActiveSheet.Paste
'
' Rename and save the active workbook by date
' set wkb to new workbook name and assign calendar cross ref
'
fName = myPath & "\Daily_Labour" _
& DateST & ".xlsx"
ActiveWorkbook.SaveAs fName, 51
Set wkb = Workbooks.Open(fName)
Set sht = wkb.Sheets("Sheet1")
refFILE = myPath & "\Cross_Ref_fCalendar.xlsx"
'
' Remove extra header info
'
Rows("1:5").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
'
' Insert Column to the left of Column D
'
Columns("E:G").Insert Shift:=xlToRight, _
CopyOrigin:=xlFormatFromRightOrBelow
'
' Update Headers that will be kept / used
'
Range("A1").Value = "FYear"
Range("E1").Value = "PD_WK"
Range("J1").Value = "JOB_GRP"
Range("F1").Value = "WKDay"
Range("G1").Value = "PD"
Range("H1").Value = "WK"
'
Rows("1:1").Select
With Selection
.HorizontalAlignment = xlCenter
End With
'
' Remove extra columns
'
Sheets("Sheet1").Range("K:K,M:P,R:AY").EntireColumn.Delete
'
' Get the last row and fill known columns
'
lastRow = Cells(Rows.Count, 1).End(xlUp).row
Range("d2:d" & lastRow).Value = aDate
'Range("d2:d" & lastRow).NumberFormat = "dd-mmm-yy" (commented as no impact on error, tried variantions here to overcome mismatch but should not matter as variable never changed here, just the range)
Range("f2:f" & lastRow).Value = WKDay
'
' Set variables for next steps
'
Set CRef = Workbooks.Open(refFILE)
Set shtJOB = CRef.Sheets("JobCross")
Set shtDATE = CRef.Sheets("fcalendar")
sht.Activate
Set rngJOBS = Range("i2:i" & lastRow)
Set rngJBGRP = shtJOB.Range("A1:b16")
Set rng = shtDATE.Range("A2:f210")
'
' Loop through jobs in column i match job in shtJOB
' put matching group in row j (Use Function vLookupVBA)
'
For Each jRow In rngJOBS
jRow.Select
job = ActiveCell.Value
JobGR = VLookupVBA(job, rngJBGRP, Null)
ActiveCell.Offset(0, 1).Value = JobGR
'end for
Next jRow
'
'Save Progress during testing:
'
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs fName, 51
'
' Fill in date parameters from Cross Ref file for Business date
' Use function rngLOOKUP to update variables then set ranges to the variables
' May be more efficient to get row number from cross ref table instead - later.
'
' shtDATE.Activate (does not seem to affect)
'
fYear = rngLOOKUP(aDate, rng, 3) '**This results in the error**
PDWK = rngLOOKUP(aDate, rng, 6)
PD = rngLOOKUP(aDate, rng, 4)
WK = rngLOOKUP(aDate, rng, 5)
'
' Fill the columns with the variables (can likely bypass the variables and put on 1 line)- later
'
Range("A2:A" & lastRow).Value = fYear
Range("E2:E" & lastRow).Value = PDWK
Range("G2:G" & lastRow).Value = PD
Range("H2:H" & lastRow).Value = WK
'
' Cleanup, save and close workbooks
'
Application.DisplayAlerts = False
CRef.Close False
wkb.SaveAs fName, 51
'
' SQL call: Load to existing datbase (GDrive), use same format as Transactions
' ?? Get sales by day? vs maintain PDWK
'
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
rngLOOKUP() expects a Date for its first parameter and a Range for its second parameter. However, you're passing it a Variant in each case. Hence, the type mismatch error. For example, in your code, you've declared aDate as follows...
Dim aDate, fYR As Date
This means that aDate is delcared as a Variant, not a Date, and fYR as a Date. So you'll need to change your delcaration statement as follows...
Dim aDate as Date, fYR As Date
Same thing with rng. And, it looks like the same thing for all your other declaration statements.

How to set a dynamic end cell while using an ActiveCell.Offset for the Start Cell?

I'm using a table to pull information from separate work books.currently the table has a set end cell, but I'm pulling into too much information. I want to set the end cell to the last row of the data in column D. I need help modifying the code to set the end cell to a dynamic range.
I've already tried to use lastRow = .Cells(.Rows.Count, col).End(xlUp).Row but I keep getting
compile error
at the preceding .Offset that is invalid or unqualified reference
Sub GetData()
Dim strWhereToCopy As String, strStartCellColName As String
Dim strListSheet As String
Dim strCopySheet As String
strListSheet = "List"
On Error GoTo ErrH
Sheets(strListSheet).Select
Range("B2").Select
'this is the main loop, we will open the files one by one and copy their data into the masterdata sheet
Set currentWB = ActiveWorkbook
Do While ActiveCell.Value <> ""
strFileName = ActiveCell.Offset(0, 1) & ActiveCell.Value
strCopyRange = ActiveCell.Offset(0, 2) & ":" & lastRow =
.Cells(.Rows.Count, col).End(xlUp).Row
strWhereToCopy = ActiveCell.Offset(0, 4).Value
strCopySheet = ActiveCell.Offset(0, 6).Value
strStartCellColName = Mid(ActiveCell.Offset(0, 5), 2, 1)
Application.Workbooks.Open strFileName, UpdateLinks:=False,
ReadOnly:=True
Set dataWB = ActiveWorkbook
Sheets(strCopySheet).Select
Range(strCopyRange).Select
Selection.Copy
currentWB.Activate
Sheets(strWhereToCopy).Select
lastRow = LastRowInOneColumn(strStartCellColName)
Cells(lastRow + 1, 1).Select
Selection.PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
Application.CutCopyMode = False
dataWB.Close False
Sheets(strListSheet).Select
ActiveCell.Offset(1, 0).Select
Loop
Exit Sub
ErrH:
MsgBox "It seems some file was missing. The data copy operation is not
complete."
Exit Sub
End Sub

Show a msgbox with missing dates where user has not enterred info

Im pretty new to vba and would like some advice
I have a timesheet spreadsheet where a user enters the amount of time it takes for them to complete tasks on a daily basis. Column A indicates the user and column B the date, then column c to x are the different tasks. The data is inputted on a form on another sheet and then a macro adds the data to my sheet and shows a messagebox confirming their hours have been enterred and the date for - I would like this message box to also show any dates (earlier than todays date) where the selected user (named within a cell on the sheet) has not enterred any hours within the current year?
Sub Macro12()
'
' Macro12 Macro
' Macro recorded 01/11/2013 by christopher.hodges
'
'
If Range("C13") = "" Then
MsgBox ("Please Select Department")
Exit Sub
End If
If Range("C14") = "" Then
MsgBox ("Please Select Employee")
Exit Sub
End If
If Range("C15") = "" Then
MsgBox ("Please Enter Date")
Exit Sub
End If
If Sheets("Form").Range("J39").Value < 7.5 Then
MSG1 = MsgBox("Hours are less than 7.5, do you wish to add?", vbYesNo, "Hours Less than 7.5")
If MSG1 = vbNo Then
Exit Sub
End If
End If
Range("E13:E35").Copy
Range("C16").PasteSpecial
Range("G13:G38").Copy
Range("C39").PasteSpecial
Range("I13:I31").Copy
Range("C65").PasteSpecial
Sheets("Data").Select
Call ShowAllRecords
Sheets("Form").Range("C13:C84").Copy
Sheets("Data").Range("A2").End(xlDown).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
Sheets("Data").Rows("3:3").Copy
Sheets("Data").Rows("3:3").Select
Selection.End(xlDown).PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
ActiveSheet.Cells(ActiveCell.Row, 1).Select
Sheets("Form").Select
Range("B16").Copy Range("C16:C83")
Range("C13:C15,E13:E35,G13:G38,I13:I32").ClearContents
Range("C15") = "=today()"
Range("A1").Select
MsgBox ("Hours for " & Range("C15").Value & " Added")
End Sub
I have only tested this on a small data set. Know that if you data set is very large this might not be the best way to go (although if it is very large a DB would be better anyway). but you can call like so.
Sub missedWork(employee_name AS String)
Dim missedDates As String
missedDates = missingDates(employee_name,earliestDate(employee_name))
If missedDates <> "" Then
msgbox "You did not enter hours for the following days: " & missedDates
End If
End Sub
Function earliestDate(emp As String) As Date
Dim e_date AS Date
Dim lcell As Range
e_date = Date()
For Each lcell in Range("$A$2","$A$" & Cells(Rows.Count, 1).End(xlUp).Row)
If lcell.Value = emp Then
If Cells(lcell.Row,"B") < e_date And Year(Cells(lcell.Row,"B")) = Year(Date) then
e_date = Cells(lcell.Row,"B")
End If
End If
Next lcell
earliestDate = e_date
End Function
Function missingDates(emp AS String, e_date As Date) AS String
Dim lcell As Range
Dim msg As String
Dim c_date As Date
msg = ""
c_date = e_date
While c_date < Date()
If WeekDayName(WeekDay(c_date)) <> "Saturday" AND WeekDayName(WeekDay(c_date)) <> "Sunday" Then
If Not(workedDate(emp,c_date)) Then
msg = msg & vbNewLine & Format(c_date,"mm/dd/yyyy")
End If
End If
c_date = DateAdd("d",1,c_date)
Wend
missingDates = msg
End Function
Function workedDate(emp AS String, c_date As Date) AS Boolean
Dim lcell As Range
For Each lcell in Range("$A$2","$A$" & Cells(Rows.Count, 1).End(xlUp).Row)
If lcell.Value = emp Then
if Cells(lcell.Row,"B") = c_date Then
workedDate = True
Exit For
End If
End If
Next lcell
End Function

Resources