PDA

View Full Version : VBA Error Referencing Excel Spreadsheet



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
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

Aflatoon
04-22-2015, 04:33 AM
It is usually helpful if you tell us what the error message is.

Try:

.Open "Select Initials,Empno from [Superstable$] order by initials", SupervisorsDB, adOpenStatic

Martin P
04-22-2015, 05:01 AM
Sorry, I thought I had included it. The error I get is "Failed To Open Supervisors Table", which is referenced later in the code. I've added some of the code again:


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)
i = 0
While Not .EOF
SupersTable(i).Initials = Trim(.Fields(0).Value)
SupersTable(i).Empno = Trim(.Fields(1).Value)
i = i + 1
.MoveNext
Wend
.Close
End With
'SupervisorsDB.Close

SupervisorError:
MSGStr = "Failed to Access the Supervisors table"

Thank you for your suggestion. I will try it and report back with results.

mancubus
04-22-2015, 05:55 AM
see if this helps:

https://social.msdn.microsoft.com/Forums/office/en-US/b1db6b26-bd7f-4310-96e8-f2b068b37533/80010105-server-automation-error?forum=exceldev

Aflatoon
04-22-2015, 07:14 AM
I'd also suggest commenting out this line to find the real error message:

On Error GoTo SupervisorError

mancubus
04-22-2015, 07:36 AM
duplicate thread:
http://www.vbaexpress.com/forum/showthread.php?52378-Microsoft-ODBC-Error-IM006

Martin P
04-22-2015, 07:55 AM
duplicate thread


Apologies for that, but I wasn't sure if the error was different or not.

Martin P
04-22-2015, 08:05 AM
I'd also suggest commenting out this line to find the real error message:

On Error GoTo SupervisorError

OK, so I have done what you suggested with the addition of the $ and commenting out. When I commented out, I then got a failed to open CSV error, which I then commented out as well and this produced the following error:
13240

I will keep trying and see if I can find out more by looking at the link posted by mancubus, but if anyone has any other ideas, I will be happy to try.

If it doesn't work, I may just re-write the entire thing and see if I can get it working that way.

Thanks for all your help so far