I have a piece of VBA (see in full below) that processes data from one sheet and outputs into another. Both spreadsheets are stored in a SharePoint site.
The code works absolutely fine on my PC and one member of the team who run it.
However, on the other 2 team members PCs an error occurs.
There are dates in column E that come into the sheet with "." separators (not "/" or "-"), but these are corrected earlier in the code and I don't believe the issue lies here.
Using the message boxes added above (marked in red) I figured out the issue.
I believe the issue is occurring in the highlighted Arr(i,5) > DateAdd ("d", 6 , CDate(SatWkStart))).
The code (on the 2 specific users PCs) states for example that:
However it works fine on my PC and the other user in the team.
Any ideas? Is there a date setting somewhere?
Full Code:
The code works absolutely fine on my PC and one member of the team who run it.
However, on the other 2 team members PCs an error occurs.
There are dates in column E that come into the sheet with "." separators (not "/" or "-"), but these are corrected earlier in the code and I don't believe the issue lies here.
Using the message boxes added above (marked in red) I figured out the issue.
I believe the issue is occurring in the highlighted Arr(i,5) > DateAdd ("d", 6 , CDate(SatWkStart))).
The code (on the 2 specific users PCs) states for example that:
- the 29th of March is not greater than the 25th March nor is it less than the 31st March
However it works fine on my PC and the other user in the team.
Any ideas? Is there a date setting somewhere?
Full Code:
VBA Code:
Option Explicit
Sub Create_Timesheet_Old()
Dim i As Long, j As Long, i2 As Long, Ctr As Long, LastRow As Long, Ctr2 As Long
Dim EmpCode As String
Dim Arr As Variant
Dim FileName As String
Dim NewTS As Workbook, Master As Workbook
Dim SatWkStart As String
Dim ContractNo As String, Remarks As String
Dim CNCtr As Long, CNColRef As Long
Dim NewCN As Boolean
Dim Continue As Boolean
Dim x1 As Single, x15 As Single
Dim iError As Long
Const SaveFolder As String = "XX-SHAREPOINT-LOCATION-XX"
Call TurnStuffOff
Set Master = ThisWorkbook
'check for '.' in dates
If InStr(1, Master.Sheets("Import").Cells(2, 5), ".") = 0 Then
MsgBox "Please insert new data, this has already been processed" & Chr(13) & "If this issue persists, please contact XX-MY EMAIL-XX"
Call TurnStuffOn
Exit Sub
End If
'sort out date col
Arr = Master.Sheets("Import").Range("A1").CurrentRegion
For i = 2 To UBound(Arr, 1)
Master.Sheets("Import").Cells(i, 5) = Replace(Master.Sheets("Import").Cells(i, 5), ".", "/")
Next i
Master.Sheets("Import").Activate
Master.Sheets("Import").Range("A1").CurrentRegion.Sort Key1:=Range("B1"), Order1:=xlAscending, Key2:=Range("E1"), Order2:=xlAscending, Key3:=Range("C1"), Order3:=xlAscending, Header:=xlYes
Arr = Master.Sheets("Import").Range("A1").CurrentRegion
'reset error message
For i = 9 To 30
For j = 2 To 4
Master.Sheets("Home").Cells(i, j) = ""
Next j
Next i
iError = 9
For i = 2 To UBound(Arr, 1)
EmpCode = Arr(i, 1)
'get saturday of week
SatWkStart = CDate(Arr(i, 5))
Do Until Weekday(CDate(SatWkStart), vbMonday) = 6
SatWkStart = DateAdd("d", -1, SatWkStart)
Loop
FileName = Replace(SatWkStart, "/", "-")
'create weekly TS
Set NewTS = Workbooks.Add
Application.DisplayAlerts = False
Master.Sheets("Timesheet").Copy After:=NewTS.Sheets(1)
NewTS.Sheets(1).Delete
Application.DisplayAlerts = True
'fill in headers
NewTS.Sheets(1).Cells(2, 3) = Arr(i, 2) 'name
NewTS.Sheets(1).Cells(2, 7) = DateAdd("d", 6, CDate(SatWkStart)) 'week end friday
NewTS.Sheets(1).Cells(2, 13) = EmpCode 'ID
'get end of employee
i2 = i
Do Until Arr(i2, 1) <> EmpCode Or i2 = UBound(Arr, 1)
i2 = i2 + 1
Loop
If i2 <> UBound(Arr, 1) Then
LastRow = i2 - 1
Else
LastRow = i2
End If
CNCtr = 0
'for Sat-Fri
For Ctr = 0 To 6
Remarks = ""
'run through whole section and record line by line
For i2 = i To LastRow
If CDate(Arr(i2, 5)) = DateAdd("d", Ctr, CDate(SatWkStart)) Then
If Arr(i2, 3) = Arr(i2, 4) Then
If UCase(Arr(i2, 3)) = "SICK" Then
ContractNo = "S"
ElseIf UCase(Arr(i2, 3)) = "HOLIDAY" Then
ContractNo = "H"
ElseIf UCase(Arr(i2, 3)) = "ABSENT" Then
ContractNo = "UA"
Else
ContractNo = "AA"
End If
Else
ContractNo = Arr(i2, 3)
End If
NewCN = True
'check if contract no already there
For Ctr2 = 1 To 6
If NewTS.Sheets(1).Cells(4, 2 + (Ctr2 * 2)) = ContractNo Then
NewCN = False
CNColRef = Ctr2
End If
Next Ctr2
If NewCN = True Then
CNCtr = CNCtr + 1
CNColRef = CNCtr
End If
x1 = 0
x15 = 0
If CNCtr > 6 Then
'record 7+ contracts error
Master.Sheets("Home").Cells(iError, 2) = EmpCode
Master.Sheets("Home").Cells(iError, 3) = SatWkStart
Master.Sheets("Home").Cells(iError, 2) = ContractNo & " not recorded within timesheet due to there being 6+ codes this week."
iError = iError + 1
Else
If NewCN = True Then
NewTS.Sheets(1).Cells(4, 2 + (CNColRef * 2)) = ContractNo
End If
'for each allocated to that contract
Continue = True
Do Until Continue = False
'record hours and rate: night 1.5, w/e 1.5 all else 1.0 unless remarked
If Ctr = 0 Or Ctr = 1 Then
x15 = x15 + Arr(i2, 6) + Arr(i2, 7)
Else
x1 = x1 + Arr(i2, 6)
x15 = x15 + Arr(i2, 7)
End If
'record remarks (col I)
If Arr(i2, 9) <> "" Then
Remarks = Remarks & Arr(i2, 9) & ", "
End If
i2 = i2 + 1
If i2 = LastRow + 1 Then
Continue = False
ElseIf Arr(i2, 3) <> ContractNo Or CDate(Arr(i2, 5)) <> DateAdd("d", Ctr, CDate(SatWkStart)) Then
Continue = False
End If
Loop
'input hours
If x1 > 0 Then
If x15 > 0 Then
NewTS.Sheets(1).Cells(6 + (Ctr * 2), 2 + (CNColRef * 2)) = x1
NewTS.Sheets(1).Cells(6 + (Ctr * 2), 2 + (CNColRef * 2) + 1) = 1
NewTS.Sheets(1).Cells(6 + (Ctr * 2) + 1, 2 + (CNColRef * 2)) = x15
NewTS.Sheets(1).Cells(6 + (Ctr * 2) + 1, 2 + (CNColRef * 2 + 1)) = 1.5
Else
NewTS.Sheets(1).Cells(6 + (Ctr * 2), 2 + (CNColRef * 2)) = x1
NewTS.Sheets(1).Cells(6 + (Ctr * 2), 2 + (CNColRef * 2) + 1) = 1
End If
ElseIf x15 > 0 Then
NewTS.Sheets(1).Cells(6 + (Ctr * 2), 2 + (CNColRef * 2)) = x15
NewTS.Sheets(1).Cells(6 + (Ctr * 2), 2 + (CNColRef * 2) + 1) = 1.5
End If
i2 = i2 - 1
End If
End If
Next i2
'enter remarks
If Remarks <> "" Then
NewTS.Sheets(1).Cells(6 + (Ctr * 2), 3) = Left(Remarks, Len(Remarks) - 1)
End If
Next Ctr
NewTS.SaveAs (SaveFolder & EmpCode & " " & FileName & ".xlsx")
NewTS.Close
i = i2 - 1
Next i
Call TurnStuffOn
Master.Sheets("Home").Activate
MsgBox "Success"
End Sub
