Trying to create a schedule for my employees using VBA coding. This project right now is currently 70% completed. Scheduling from January to Oct has been done. I am just left with Nov. As this code was passed down to me, when I try to run the code I encountered error message" Run-time error '-2147221080(800401a8)': Automation Error"
The code was able to run perfectly and read through monday to friday. However I cannot run the code when passed to me
Please help Thank You!
The code:
The code was able to run perfectly and read through monday to friday. However I cannot run the code when passed to me
Please help Thank You!
The code:
VBA Code:
Option Explicit
Sub Employee()
Dim path As String
Dim tdate As Date
Dim cellrange As Range
Dim cellsrange As Range
Dim found As Boolean
Dim foundMon As Boolean
Dim cella As Range
Dim celli As Range
Dim cell As Range
Dim tdatecell As Range
Dim startcell As Range
Dim endcell As Range
Dim col As Integer
Dim mon As Range
Dim monfound As Range
Dim afound As Range
Dim ifound As Range
Dim plannedlist() As Variant
Dim unplannedlist() As Variant
Dim startcol As Range
Dim endcol As Range
Dim counter1 As Long
Dim newt As Long
Dim cellt As Range
Dim arow As Long
Dim counter2 As Long
Dim cellti As Range
Dim irow As Long
Dim i As Long
Dim item As Variant
Dim foundi As Boolean
Dim foundu As Boolean
Dim foundx As Boolean
Dim foundy As Boolean
Dim foundz As Boolean
Dim cleanedCellValue As String
Dim Source As Range
Dim lastcol As Range
Dim foundvalue As Range
Dim agentrow As Long
Dim cellend As Range
Dim endfound As Range
Dim endrow As Long
Dim internrow As Long
Dim checkcell As Range
Dim celladd As Range
Dim interncounter As Long
Dim agentcounter As Long
Dim counter3 As Long
Dim counter4 As Long
Dim counter5 As Long
Dim agentcall As Long
Dim interncall As Long
Dim atrng As Long
Dim itrng As Long
Dim atrainfound As Range
Dim cellatrain As Range
Dim atrainrow As Long
Dim agentontrain As Range
Dim internontrain As Range
Dim itrainfound As Range
Dim itrainrow As Long
Dim cellitrain As Range
Dim trainagent As Range
Dim trainintern
Dim sheetName As String
Dim pathinput As String
Dim schedpath As Range
Dim wb As Workbook
Dim ws As Worksheet
' Dim weekrange As Range
' Dim startrow As Range
' Dim endweekrow As Range
' Dim path2input As String
' Dim wb2 As Workbook
' Dim sheetName2 As String
' Dim reportpath As Range
' Dim findfriday As Long
' Dim cellp As Range
' Dim celldate As Range
' Dim todaydatecell As Range
'===========================================================
plannedlist = Array("AL", "BL", "EL", "FFLM", "FFL", "ML", "RS", "SCL", "TRG", "UAL", "TO", "OIL")
unplannedlist = Array("CL", "FCL", "HL", "SL", "NPL", "PL", "SCL", "UAL")
' Prompt for the file path
pathinput = InputBox("Please enter the path. Example: C:\Users\hi\Downloads\VBA\Employees Schedule - 2024.xlsx", "SD Schedule File Path")
' Open the workbook
Set wb = Workbooks.Open(pathinput, ReadOnly:=True)
' Prompt for the sheet name
sheetName = InputBox("Enter the sheet name:")
path = "C:\Users\hi\Downloads\VBA\Employees Schedule - 2024.xlsx"
Workbooks.Open path, ReadOnly:=True
sheetName = InputBox("Enter the sheet name:")
If WorksheetExists(sheetName) Then
Set schedpath = wb.Worksheets(sheetName).Range("A1:AG42")
Else
MsgBox "Sheet not found."
End If
Set cellrange = Range("C4:AG4")
'Set cellrange = Worksheets("sheetName").Range("C4:AH4")
tdate = Format(Date, "dd-mm-yyyy")
found = False
For Each cell In cellrange
If cell.value = tdate Then
found = True
Set tdatecell = cell
Exit For
End If
Next cell
If found = True Then
MsgBox "Found " & tdate & " " & tdatecell.Address(False, False)
Set startcell = Range("A3")
Set endcell = tdatecell.Offset(0, -3)
For col = endcell.column To startcell.column Step -1
Set cell = cells(3, col)
If cell.value = "Fri" Then
Set monfound = cell
foundMon = True
Exit For
End If
Next col
If foundMon Then
MsgBox "Fri found at " & monfound.Address(False, False)
Else
MsgBox "No Fri found "
End If
If Not foundMon Then
Set Source = Worksheets("Nov 24")
' Find the last column in row 3 of the other source sheet
lastcol = Source.cells(3, Source.Columns.Count).End(xlToLeft).column
' Loop backwards through the columns in row 3 of the other source sheet
For col = lastcol To 1 Step -1
If Source.cells(3, col).value = "Fri" Then
foundvalue = Source.cells(3, col).value
Exit For
End If
Next col
End If
' Check the value two rows below monfound IsEmpty(monfound.Offset(2, 0).value) Or
If Not IsNumeric(monfound.Offset(2, 0).value Like "*[!0-9]*") Then
' Look at the column before monfound Not IsEmpty(checkcell.Offset(2, 0).value) And
Set checkcell = monfound.Offset(0, -1)
If Not IsNumeric(checkcell.Offset(2, 0).value Like "*[!0-9]*") Then
Set celladd = Range(checkcell.Address)
Else
MsgBox "theres no numeric values in this column"
End If
Else
MsgBox "Value two rows below " & monfound.Address(False, False) & " is numeric."
End If
Else
MsgBox tdate & " not found."
End If
Set cellsrange = Range("A1:A100")
Set startcol = Range(monfound.Address)
Set endcol = Range(tdatecell.Address)
For newt = startcol.column To endcol.column - 1
counter1 = 0
counter2 = 0
counter3 = 0
counter4 = 0
counter5 = 0
For Each cella In cellsrange
If Not IsEmpty(cellsrange) Then
If cella.value = "A" Then
Set afound = cella
arow = afound.Row
Exit For
' End If
End If
End If
Next cella
For Each celli In cellsrange
If Not IsEmpty(cellsrange) Then
If celli.value = "I" Then
Set ifound = celli
irow = ifound.Row
Exit For
End If
End If
Next celli
For Each cellend In cellsrange
If Not IsEmpty(cellsrange) Then
If cellend.value = "Email Coordinator" Then
Set endfound = cellend
endrow = endfound.Row
' Debug.Print "Email corrdinator found at " & endrow
Exit For
End If
End If
Next cellend
agentcounter = 0
atrng = 0
For agentrow = arow To irow - 1
Set agentontrain = cells(agentrow, 1)
For Each cellatrain In agentontrain
' If Not IsEmpty(cellatrain) Then
If cellatrain.value = "T" Then
' cellendfound = True
Set atrainfound = cellatrain
atrainrow = atrainfound.Row
' Debug.Print "training found at " & atrainrow
'Exit For
' Else
' Debug.Print "Finding T is a issue"
' Debug.Print "this is atrainrow " & atrainrow
' Debug.Print "this is newt " & newt
Set trainagent = cells(atrainrow, newt)
If Not IsEmpty(trainagent) Then
atrng = atrng + 1
' Debug.Print atrng
Else
atrng = atrng + 0
' Debug.Print atrng
'
End If
End If
' End If
Next cellatrain
Set cellt = cells(agentrow, newt)
If Not IsEmpty(cellt) Then
agentcounter = agentcounter + 1
cleanedCellValue = CleanAlpha(cellt.value)
' Debug.Print "agents: " & agentcounter
'Initialize the found flag
foundi = False
foundu = False
' Check if any item from plannedlist is a substring of the cleaned cell value
For Each item In unplannedlist
If InStr(cleanedCellValue, item) > 0 Then
foundi = True
Exit For
End If
Next item
'unplanned list
If foundi Then
' Debug.Print "Found agent unplanned list " & cellt.Address & " with cleaned value: " & cleanedCellValue
counter1 = counter1 + 1
' Debug.Print "Unplanned list " & counter1
Else
' Debug.Print "No match for cell: " & cellt.Address & " with cleaned value: " & cleanedCellValue
End If
For Each item In plannedlist
If InStr(cleanedCellValue, item) > 0 Then
foundu = True
Exit For
End If
Next item
' Planned list
If foundu Then
' Debug.Print "Found agent planned list " & cellt.Address & " with cleaned value: " & cleanedCellValue
counter2 = counter2 + 1
' Debug.Print "Planned list " & counter2
' Else
' Debug.Print "No match for cell: " & cellt.Address & " with cleaned value: " & cleanedCellValue
End If
Else
agentcounter = agentcounter + 0
End If
Next agentrow
interncounter = 0
itrng = 0
For internrow = irow To endrow - 1
Set internontrain = cells(internrow, 1)
For Each cellitrain In internontrain
' If Not IsEmpty(cellatrain) Then
If cellitrain.value = "T" Then
' cellendfound = True
Set itrainfound = cellitrain
itrainrow = itrainfound.Row
' Debug.Print "training found at " & itrainrow
'Exit For
' Else
' Debug.Print "Finding T is a issue"
' Debug.Print "this is itrainrow " & itrainrow
' Debug.Print "this is newt " & newt
Set trainintern = cells(itrainrow, newt)
If Not IsEmpty(trainintern) Then
itrng = itrng + 1
' Debug.Print "this is the interns trng: " & itrng
Else
itrng = itrng + 0
' Debug.Print "no interns: " & itrng
'
'Exit For
End If
End If
' End If
Next cellitrain
' Debug.Print "interns: " & interncounter
Set cellti = cells(internrow, newt)
If Not IsEmpty(cellti) Then
interncounter = interncounter + 1
cleanedCellValue = CleanAlpha(cellti.value)
' Debug.Print "interns: " & interncounter
' Initialize the found flag
foundx = False
foundy = False
' unplannedlist
For Each item In unplannedlist
If InStr(cleanedCellValue, item) > 0 Then
foundx = True
Exit For
End If
Next item
' Debug output
If foundx Then
' Debug.Print "Found intern unplanned list " & cellti.Address & " with cleaned value: " & cleanedCellValue
counter3 = counter3 + 1
Else
'Debug.Print "No match for cell: " & cellti.Address & " with cleaned value: " & cleanedCellValue
End If
'Plannedlist
For Each item In plannedlist
If InStr(cleanedCellValue, item) > 0 Then
foundy = True
Exit For
End If
Next item
' Debug output
If foundy Then
' Debug.Print "Found intern planned list " & cellti.Address & " with cleaned value: " & cleanedCellValue
counter4 = counter4 + 1
Else
' Debug.Print "No match for cell: " & cellti.Address & " with cleaned value: " & cleanedCellValue
End If
'BTS list
foundz = (InStr(cleanedCellValue, "BTS") > 0)
' Debug output
If foundz Then
' Debug.Print "Found intern BTS " & cellti.Address & " with cleaned value: " & cleanedCellValue
counter5 = counter5 + 1
Else
' Debug.Print "No match for cell: " & cellti.Address & " with cleaned value: " & cleanedCellValue
End If
Else
interncounter = interncounter + 0
End If
Next internrow
agentcall = agentcounter - counter1 - counter2 - atrng
interncall = interncounter - counter3 - counter4 - counter5 - itrng
' Debug.Print "agents unplanned list: " & counter1
' Debug.Print "agents planned list: " & counter2
' Debug.Print "agents on call: " & agentcall
' Debug.Print "agents on training: " & atrng
' Debug.Print "interns on training: " & itrng
' Debug.Print "interns unplanned list: " & counter3
' Debug.Print "interns planned list: " & counter4
' Debug.Print "interns bts: " & counter5
' Debug.Print "interns on call: " & interncall
' Debug.Print interncounter & " This is the total interns"
' Debug.Print agentcounter & " This is the total agents"
Dim myArray1() As Variant
Dim a As Integer
' Dim userInput As String
' Initialize the array with some numbers
myArray1 = Array(agentcall, atrng, counter2, counter1, interncall, itrng, counter4, counter3, counter5)
' Loop through the array
For a = LBound(myArray1) To UBound(myArray1)
' Print the current index
Debug.Print myArray1(a)
Next a
' Debug.Print agentcall
Next newt
wb.Close SaveChanges:=False ' Change to True if you want to save changes
Dim weekrange As Range
Dim startrow As Range
Dim endweekrow As Range
Dim path2input As String
Dim wb2 As Workbook
Dim sheetName2 As String
Dim reportpath As Range
Dim findfriday As Long
Dim cellp As Range
Dim celldate As Range
Dim todaydatecell As Range
Dim matchdate As Range
Dim tdates As Date
Dim daterange As Range
Dim founddate As Boolean
Dim celld As Range
Dim tdatecells As Range
Dim cols As Long
Dim startcells As Range
Dim endcells As Range
Dim cellc As Range
Dim monsfound As Range
Dim readrow As Long
' Dim startrow As Range
Dim colilm As Long
' Prompt for the file path
path2input = InputBox("Please enter the path. Example: C:\Users\hi\Downloads\VBA\Employees Schedule - 2024.xlsx", "SD Schedule File Path")
' Open the workbook
Set wb2 = Workbooks.Open(path2input, ReadOnly:=True)
sheetName2 = InputBox("Enter the sheet name:")
If WorksheetExists2(sheetName2) Then
Set reportpath = wb2.Worksheets(sheetName2).Range("A1:AA56")
Else
MsgBox "Sheet not found."
End If
Set daterange = Range("B4:B70")
tdates = Format(Date, "dd-mm-yyyy")
founddate = False
For Each celld In daterange
If celld.value = tdate Then
founddate = True
Set tdatecells = celld
Exit For
End If
Next celld
If found = True Then
Debug.Print "Found " & tdates & " " & tdatecells.Address(False, False)
End If
Set startcells = Range("A4")
Set endcells = tdatecells.Offset(-1, 0)
For cols = endcells.Row To startcells.Row Step -1
Set cellc = cells(col, 1)
If cellc.value = "Fri" Then
Set monsfound = cell
Debug.Print "Found friday at: " & monsfound.Address(False, False)
foundMon = True
Exit For
End If
Next cols
Set startrow = Range(monfound.Address)
For readrow = startrow.Row To endcell.Row Step 1
For colilm = 17 To 25 ' Columns Q to Y
Debug.Print "Value at " & wb2.cells(readrow, cols).Address(False, False) & ": " & wb2.cells(readrow, cols).value
Next colilm
Next readrow
End Sub
Function CleanAlpha(ByVal str As String) As String
Dim i As Integer
Dim result As String
Dim c As String
result = ""
For i = 1 To Len(str)
c = Mid(str, i, 1)
' Check if the character is a number
If c Like "[0-9]" Then
Exit For ' Stop processing if a number is encountered
End If
' Check if the character is an alphabetic letter or a hyphen and not a space
If (c Like "[A-Za-z]" Or c = "-") And c <> " " Then
result = result & c
End If
Next i
CleanAlpha = result
End Function
Function WorksheetExists(sheetName As String) As Boolean
On Error Resume Next
WorksheetExists = Not Worksheets(sheetName) Is Nothing
On Error GoTo 0
End Function
Function WorksheetExists2(sheetName2 As String) As Boolean
On Error Resume Next
WorksheetExists2 = Not Worksheets(sheetName2) Is Nothing
On Error GoTo 0
End Function
Last edited by a moderator:
