Martin P
04-21-2015, 07:31 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, Supervisors As New ADODB.Recordset, Fixups As New ADODB.Recordset
Dim SupersTable() As SuperRefs
Dim SuperSource As String
Dim ProfilesDB As New ADODB.Connection, 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, Empno As String, ShortName As String, Project As String
Dim Supervisor As String, SupervisorInits As String, ProjectTitle As String
Dim Duplicates As Long, ErrorCount As Long
Dim Comment As String
Dim i As Long, j As Long, k As Long
Dim SQLStr As String, MSGStr As String
Dim ProcessName As String, DateStr As String
Dim RecordError As Boolean, RecordWarning As Boolean, RecordChange As Boolean
Dim ErrorColourCode As Long, WarningColourCode As Long
Dim ChangeColourCode As Long, RecordColourCode As Long
Dim LowPtr As Long, HighPtr As Long, MidPtr As Long, 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, Supervisors As New ADODB.Recordset, Fixups As New ADODB.Recordset
Dim SupersTable() As SuperRefs
Dim SuperSource As String
Dim ProfilesDB As New ADODB.Connection, 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, Empno As String, ShortName As String, Project As String
Dim Supervisor As String, SupervisorInits As String, ProjectTitle As String
Dim Duplicates As Long, ErrorCount As Long
Dim Comment As String
Dim i As Long, j As Long, k As Long
Dim SQLStr As String, MSGStr As String
Dim ProcessName As String, DateStr As String
Dim RecordError As Boolean, RecordWarning As Boolean, RecordChange As Boolean
Dim ErrorColourCode As Long, WarningColourCode As Long
Dim ChangeColourCode As Long, RecordColourCode As Long
Dim LowPtr As Long, HighPtr As Long, MidPtr As Long, 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