Martin P
04-21-2015, 06:24 AM
Hello
I have had an error with the following code for a long time now, and it seems to be linked to a spreadsheet that is referenced in the code. I have checked this spreadsheet and I cannot see any reason why it fails as all the necessary titles, and other names referenced are there. However, as it does not work, and keeps throwing the error message, I must be missing something.
The code that throws the error is highlighted in red below. Up to this point, everything works:
Option Explicit
Type SuperRefs
Initials As String
Empno As String
End Type
Type ProfileDetails
ShortName As String
Project As String
Supervisor As String
Category As String
LeaveDate As Date
End Type
Public Sub BuildLabourLoading()
' This sub depends upon the format of the Labour Loading workbook NOT CHANGING
' It is supplied 'as is' and must be used with caution
Dim SupervisorsDB As New ADODB.Connection
Dim Supervisors As New ADODB.Recordset
Dim Fixups As New ADODB.Recordset
Dim SupersTable() As SuperRefs
Dim SuperSource As String
Dim ProfilesDB As New ADODB.Connection
Dim Profiles As New ADODB.Recordset
Dim ProfileEmpnos() As String
Dim ProfileData() As ProfileDetails
Dim Source As Range
Dim Target As Worksheet
Dim TargetRow As Long
Dim TargetFile As String
Dim Empno As String
Dim ShortName As String
Dim Project As String
Dim Supervisor As String
Dim SupervisorInits As String
Dim ProjectTitle As String
Dim Duplicates As Long
Dim ErrorCount As Long
Dim Comment As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim SQLStr As String
Dim MSGStr As String
Dim ProcessName As String
Dim DateStr As String
Dim RecordError As Boolean
Dim RecordWarning As Boolean
Dim RecordChange As Boolean
Dim ErrorColourCode As Long
Dim WarningColourCode As Long
Dim ChangeColourCode As Long
Dim RecordColourCode As Long
Dim LowPtr As Long
Dim HighPtr As Long
Dim MidPtr As Long
Dim ProfilePtr As Long
ProcessName = "Collecting Labour Loading"
ErrorCount = 0
ErrorColourCode = 3
WarningColourCode = 45
ChangeColourCode = 35
With frmSetDate
.Caption = ProcessName
.Show
If .lbGo = "N" Then Exit Sub
DateStr = Format(.tbDate, "DD/MM/YYYY")
End With
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set Source = ActiveSheet.Cells
Worksheets.Add
Set Target = ActiveSheet
With Target
.Cells(1, 1).Value = "EMP NO"
.Cells(1, 2).Value = "WEEK START"
.Cells(1, 3).Value = "SUPERVISOR"
.Cells(1, 4).Value = "CONTRACT"
.Cells(1, 5).Value = "Contract"
.Cells(1, 6).Value = "Employee"
.Cells(1, 7).Value = "ErrorFlag"
.Cells(1, 8).Value = "ChangeFlag"
.Cells(1, 9).Value = "Comment"
End With
SuperSource = GetEnvironmentItem("DBSUPERS")
If SuperSource = "###" Then Exit Sub
TargetFile = GetEnvironmentItem("MITREFCSV")
If TargetFile = "###" Then Exit Sub
On Error GoTo CSVError
Open TargetFile For Output As #1
Print #1, """EMP NO"",""WEEK START"",""SUPERVISOR"",""CONTRACT"""
TargetRow = 2
On Error GoTo SupervisorError
SupervisorsDB.Open "DSN=Excel Files;DBQ=" & SuperSource & ";"
With Supervisors
.Open "Select Initials,Empno from Superstable order by initials", SupervisorsDB, adOpenStatic
ReDim SupersTable(.RecordCount - 1)
Can anybody shed any light on this, as I seem to be unable to get it to work no matter what I do? If you need any more information, please say, and I will provide as much as I can. I hope someone can help me.
Thank you
I have had an error with the following code for a long time now, and it seems to be linked to a spreadsheet that is referenced in the code. I have checked this spreadsheet and I cannot see any reason why it fails as all the necessary titles, and other names referenced are there. However, as it does not work, and keeps throwing the error message, I must be missing something.
The code that throws the error is highlighted in red below. Up to this point, everything works:
Option Explicit
Type SuperRefs
Initials As String
Empno As String
End Type
Type ProfileDetails
ShortName As String
Project As String
Supervisor As String
Category As String
LeaveDate As Date
End Type
Public Sub BuildLabourLoading()
' This sub depends upon the format of the Labour Loading workbook NOT CHANGING
' It is supplied 'as is' and must be used with caution
Dim SupervisorsDB As New ADODB.Connection
Dim Supervisors As New ADODB.Recordset
Dim Fixups As New ADODB.Recordset
Dim SupersTable() As SuperRefs
Dim SuperSource As String
Dim ProfilesDB As New ADODB.Connection
Dim Profiles As New ADODB.Recordset
Dim ProfileEmpnos() As String
Dim ProfileData() As ProfileDetails
Dim Source As Range
Dim Target As Worksheet
Dim TargetRow As Long
Dim TargetFile As String
Dim Empno As String
Dim ShortName As String
Dim Project As String
Dim Supervisor As String
Dim SupervisorInits As String
Dim ProjectTitle As String
Dim Duplicates As Long
Dim ErrorCount As Long
Dim Comment As String
Dim i As Long
Dim j As Long
Dim k As Long
Dim SQLStr As String
Dim MSGStr As String
Dim ProcessName As String
Dim DateStr As String
Dim RecordError As Boolean
Dim RecordWarning As Boolean
Dim RecordChange As Boolean
Dim ErrorColourCode As Long
Dim WarningColourCode As Long
Dim ChangeColourCode As Long
Dim RecordColourCode As Long
Dim LowPtr As Long
Dim HighPtr As Long
Dim MidPtr As Long
Dim ProfilePtr As Long
ProcessName = "Collecting Labour Loading"
ErrorCount = 0
ErrorColourCode = 3
WarningColourCode = 45
ChangeColourCode = 35
With frmSetDate
.Caption = ProcessName
.Show
If .lbGo = "N" Then Exit Sub
DateStr = Format(.tbDate, "DD/MM/YYYY")
End With
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
Set Source = ActiveSheet.Cells
Worksheets.Add
Set Target = ActiveSheet
With Target
.Cells(1, 1).Value = "EMP NO"
.Cells(1, 2).Value = "WEEK START"
.Cells(1, 3).Value = "SUPERVISOR"
.Cells(1, 4).Value = "CONTRACT"
.Cells(1, 5).Value = "Contract"
.Cells(1, 6).Value = "Employee"
.Cells(1, 7).Value = "ErrorFlag"
.Cells(1, 8).Value = "ChangeFlag"
.Cells(1, 9).Value = "Comment"
End With
SuperSource = GetEnvironmentItem("DBSUPERS")
If SuperSource = "###" Then Exit Sub
TargetFile = GetEnvironmentItem("MITREFCSV")
If TargetFile = "###" Then Exit Sub
On Error GoTo CSVError
Open TargetFile For Output As #1
Print #1, """EMP NO"",""WEEK START"",""SUPERVISOR"",""CONTRACT"""
TargetRow = 2
On Error GoTo SupervisorError
SupervisorsDB.Open "DSN=Excel Files;DBQ=" & SuperSource & ";"
With Supervisors
.Open "Select Initials,Empno from Superstable order by initials", SupervisorsDB, adOpenStatic
ReDim SupersTable(.RecordCount - 1)
Can anybody shed any light on this, as I seem to be unable to get it to work no matter what I do? If you need any more information, please say, and I will provide as much as I can. I hope someone can help me.
Thank you