Private Sub Save_Leave_Click()
On Error GoTo ErrorHandler
Dim MyFile As String
Dim appExcel As Object
Dim MyBook As Object
Dim MySheet As Object
Dim sID As String
Dim sFName As String
Dim sLName As String
Dim sLeave_Type As String
Dim dLeave_Date As Date
Dim sYear_St As String
sID = Me.Personnel_ID
sFName = Me.First_Name
sLName = Me.Last_Name
sLeave_Type = Me.Leave_Type
dLeave_Date = Me.Leave_Date
dYear_St = CDate("01/01/" & Year(dLeave_Date))
MyFile = "H:\Leave Register.xlsx" ' Data file to update
' Open the data file
Set appExcel = GetObject(, "Excel.Application")
Set MyBook = appExcel.workbooks.Open(MyFile)
' Modify the data file
With appExcel
Dim iLastRow As Integer
Dim i As Integer
Dim iRow As Integer
Dim iCol As Integer
Dim rRange As Range
.ScreenUpdating = False
' Find the correct sheet
For i = 1 To MyBook.sheets.Count
If Right(MyBook.sheets(i).Name, 2) = Right(dLeave_Date, 2) Then
Set MySheet = MyBook.sheets(i)
Exit For
End If
Next i
' Check if sheet is Leap Year
If .Range("BK3") = 1 Then 'Not a leap year
iCol = dLeave_Date - dYear_St + 4
Else
iCol = dLeave_Date - dYear_St + 5
End If
' Find the staff and update date cell
With MySheet
.Activate
iLastRow = .Range("A65536").End(xlUp).Row
Set rRange = .Cells.Find(what:=sID, After:=.Range("A1"), LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If rRange Is Nothing Then
iRow = iLastRow + 1
.Range("A" & iRow) = sFName
.Range("B" & iRow) = sLName
.Range("C" & iRow) = sID
Else
iRow = rRange.Row
End If
.Cells(iRow, iCol) = "OFF"
End With
MyBook.Close True
End With
MsgBox "Excel sheet updated.", vbInformation + vbOKOnly, "Leave Form Update"
Exit_Sub:
appExcel.ScreenUpdating = True
Set appExcel = Nothing
Set rRange = Nothing
Set MyBook = Nothing
Set MySheet = Nothing
Exit Sub
ErrorHandler:
If Err = 429 Then ' Excel is not running; open Excel with CreateObject
Set appExcel = CreateObject("Excel.Application")
appExcel.Visible = True
Resume Next
Else
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume Exit_Sub
End If
End Sub