Importing a multi-sheet Excel spreadsheet into Access

[Tom S]

I am running into two problems attempting to load data from an Excel
Spreadsheet into Access.

1. Access is locking the file open when the code is run
2. The program abends with run-time error code '9' - "subscript out of
range error"

The Excel workbook is set up with the sheet names on the 1st sheet and the
spreadsheet is updating frequently with new sheets being added or existing
sheets being updated. I am attempting to read in the sheet names on the 1st
sheet into an array, then determine if the sheet is new or just an update.
If it is new, then it would add the sheet information to the database,
otherwise it would just update the data in Access. Here's the code:

Public Function import_rlc()

Dim strFileName As String, strTab As String, strSql As String, strCell As
String
Dim strCell2 As String, strAdd As String
Dim xlsApp As Object
Dim xlsWB1 As Object
Dim xlsWS1 As Object
Dim xlsWS2 As Object
Dim intCol As Integer
Dim intRow As Integer
Dim blnProject As Boolean, blnNewP As Boolean
Dim dblCell As Double
Dim rst1 As Recordset, rst2 As Recordset
Dim col As Integer
Dim row As Integer

strFileName = "c:\RLC.xls"
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = False

Set xlsWB1 = xlsApp.Workbooks.Open(strFileName)
Set xlsWS1 = xlsWB1.Worksheets("Index")

MaxRow = 200
MaxCol = 15
ReDim CaseArray(MaxRow, MaxCol)

For row = 1 To MaxRow
For col = 1 To MaxCol
CaseArray(row, col) = xlsWS1.cells(row, col).Value
Next
Next


xlsWB1.Close
set xlsApp = Nothing

intRow = 1

Do Until intRow = 200

strTab = CaseArray(intRow, 1)

GoSub check_tab

If blnProject = True Then
Set xlsApp = CreateObject("Excel.Application")
Set xlsWB1 = xlsApp.Workbooks.Open(strFileName)
Set xlsWS2 = xlsWB1.Worksheets(strTab)
GoSub import_tab
xlsWB1.Close
Set xlsWB1 = Nothing
Set xlsWS2 = Nothing
Set xlsApp = Nothing
End If

intRow = intRow + 1

Loop

Exit Function

check_tab: 'check to see if the cell value is valid project

blnProject = True

strSql = "SELECT Tab_Name FROM tbl_NonProject_Tabs WHERE Tab_Name = "
strSql = strSql & "'" & strTab & "'"

'tbl_NonProject_Tabs lists those tabs that are not real projects

Set rst1 = CurrentDb.OpenRecordset(strSql)
If rst1.EOF = False Then
blnProject = False 'if value is in table then not a project
rst1.Close
End If

If strTab = "" Then
blnProject = False 'if value is blank then not a project
End If

Return


check_new_proj: 'check to see if the project exists on database

blnNewP = False

strSql = "Select * FROM tbl_projects WHERE project_code = '"
strSql = strSql & strCell & "'"

Set rst1 = CurrentDb.OpenRecordset(strSql)

If rst1.EOF = True Then
blnNewP = True
End If
rst1.Close

Return

add_proj: 'add new project to database

Set rst2 = CurrentDb.OpenRecordset("tbl_projects", dbOpenDynaset)

rst2.AddNew
rst2![project_code] = strCell
rst2![project_description] = strCell2
rst2![Active] = True
rst2.Update

rst2.Close

Return


import_tab: 'read data from tab and add new data

strCell = xlsWS2.cells(2, 4).Value
strCell2 = xlsWS2.cells(2, 5).Value
GoSub check_new_proj 'check to see if project exists in database
If blnNewP = True Then
GoSub add_proj 'add project if project doesn't exist
End If
Return


End Function

 

[RoyVidar]

I am running into two problems attempting to load data from an Excel
Spreadsheet into Access.

1. Access is locking the file open when the code is run
2. The program abends with run-time error code '9' - "subscript out
of range error"

The Excel workbook is set up with the sheet names on the 1st sheet
and the spreadsheet is updating frequently with new sheets being
added or existing sheets being updated. I am attempting to read in
the sheet names on the 1st sheet into an array, then determine if
the sheet is new or just an update. If it is new, then it would add
the sheet information to the database, otherwise it would just
update the data in Access. Here's the code:

Public Function import_rlc()

Dim strFileName As String, strTab As String, strSql As String,
strCell As String
Dim strCell2 As String, strAdd As String
Dim xlsApp As Object
Dim xlsWB1 As Object
Dim xlsWS1 As Object
Dim xlsWS2 As Object
Dim intCol As Integer
Dim intRow As Integer
Dim blnProject As Boolean, blnNewP As Boolean
Dim dblCell As Double
Dim rst1 As Recordset, rst2 As Recordset
Dim col As Integer
Dim row As Integer

strFileName = "c:\RLC.xls"
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = False

Set xlsWB1 = xlsApp.Workbooks.Open(strFileName)
Set xlsWS1 = xlsWB1.Worksheets("Index")

MaxRow = 200
MaxCol = 15
ReDim CaseArray(MaxRow, MaxCol)

For row = 1 To MaxRow
For col = 1 To MaxCol
CaseArray(row, col) = xlsWS1.cells(row, col).Value
Next
Next


xlsWB1.Close
set xlsApp = Nothing

intRow = 1

Do Until intRow = 200

strTab = CaseArray(intRow, 1)

GoSub check_tab

If blnProject = True Then
Set xlsApp = CreateObject("Excel.Application")
Set xlsWB1 = xlsApp.Workbooks.Open(strFileName)
Set xlsWS2 = xlsWB1.Worksheets(strTab)
GoSub import_tab
xlsWB1.Close
Set xlsWB1 = Nothing
Set xlsWS2 = Nothing
Set xlsApp = Nothing
End If

intRow = intRow + 1

Loop

Exit Function

check_tab: 'check to see if the cell value is valid project

blnProject = True

strSql = "SELECT Tab_Name FROM tbl_NonProject_Tabs WHERE Tab_Name
= " strSql = strSql & "'" & strTab & "'"

'tbl_NonProject_Tabs lists those tabs that are not real projects

Set rst1 = CurrentDb.OpenRecordset(strSql)
If rst1.EOF = False Then
blnProject = False 'if value is in table then not a
project rst1.Close
End If

If strTab = "" Then
blnProject = False 'if value is blank then not a project
End If

Return


check_new_proj: 'check to see if the project exists on database

blnNewP = False

strSql = "Select * FROM tbl_projects WHERE project_code = '"
strSql = strSql & strCell & "'"

Set rst1 = CurrentDb.OpenRecordset(strSql)

If rst1.EOF = True Then
blnNewP = True
End If
rst1.Close

Return

add_proj: 'add new project to database

Set rst2 = CurrentDb.OpenRecordset("tbl_projects", dbOpenDynaset)

rst2.AddNew
rst2![project_code] = strCell
rst2![project_description] = strCell2
rst2![Active] = True
rst2.Update

rst2.Close

Return


import_tab: 'read data from tab and add new data

strCell = xlsWS2.cells(2, 4).Value
strCell2 = xlsWS2.cells(2, 5).Value
GoSub check_new_proj 'check to see if project exists in
database If blnNewP = True Then
GoSub add_proj 'add project if project doesn't exist
End If
Return


End Function

In addition to Chris O'C's comments

Especially one part of the code is very ineffective, and might
probably prove to be/become a memory leak.

Within a loop, you are not only reopening the same workbook umpteen
times (umpteen being about 200, I think), but also reinstantiate
Excel. Seems to me you could do the following in stead - NOTE - also
remove the lines closing the workbook (xlsWB1) and releasing the
application (xlsApp) above

Do Until intRow = 200

strTab = CaseArray(intRow, 1)

GoSub check_tab

If blnProject = True Then
Set xlsWS2 = xlsWB1.Worksheets(strTab)
GoSub import_tab
Set xlsWS2 = Nothing
End If

intRow = intRow + 1

Loop

To read the limits of an Excel Range dynamicly, you can do something
like the following, for instance if you know the starting range of it,
or a cell within the range.

' First row
Debug.Print xlsWS2.Range("A4").CurrentRegion.Row
' First Column
Debug.Print xlsWS2.Range("A4").CurrentRegion.Column
' Number of rows
Debug.Print xlsWS2.Range("A4").CurrentRegion.Rows.Count
' number of columns
Debug.Print xlsWS2.Range("A4").CurrentRegion.Columns.Count
' LastRow
Debug.Print xlsWS2.Range("A4").CurrentRegion.Row - 1 + _
Debug.Print xlsWS2.Range("A4").CurrentRegion.Rows.Count

Or, for a loop, you could run until you reach an empty cell

do while not IsEmpty(xlsWS1.cells(row, col).Value)

One question though, which line does it error on?

 

[Tom S]

The error occurs on the following line:

Set xlsWS2 = xlsWB1.Worksheets(strTab)

Typically when attempting to read the 3rd or 4th sheet in the workbook. I
realize that opening and closing is extremely inefficient. I was thinking
that the workbook being locked opened was causing the error, so I was trying
to close it each time.

I am running into two problems attempting to load data from an Excel
Spreadsheet into Access.

1. Access is locking the file open when the code is run
2. The program abends with run-time error code '9' - "subscript out
of range error"

The Excel workbook is set up with the sheet names on the 1st sheet
and the spreadsheet is updating frequently with new sheets being
added or existing sheets being updated. I am attempting to read in
the sheet names on the 1st sheet into an array, then determine if
the sheet is new or just an update. If it is new, then it would add
the sheet information to the database, otherwise it would just
update the data in Access. Here's the code:

Public Function import_rlc()

Dim strFileName As String, strTab As String, strSql As String,
strCell As String
Dim strCell2 As String, strAdd As String
Dim xlsApp As Object
Dim xlsWB1 As Object
Dim xlsWS1 As Object
Dim xlsWS2 As Object
Dim intCol As Integer
Dim intRow As Integer
Dim blnProject As Boolean, blnNewP As Boolean
Dim dblCell As Double
Dim rst1 As Recordset, rst2 As Recordset
Dim col As Integer
Dim row As Integer

strFileName = "c:\RLC.xls"
Set xlsApp = CreateObject("Excel.Application")
xlsApp.Visible = False

Set xlsWB1 = xlsApp.Workbooks.Open(strFileName)
Set xlsWS1 = xlsWB1.Worksheets("Index")

MaxRow = 200
MaxCol = 15
ReDim CaseArray(MaxRow, MaxCol)

For row = 1 To MaxRow
For col = 1 To MaxCol
CaseArray(row, col) = xlsWS1.cells(row, col).Value
Next
Next


xlsWB1.Close
set xlsApp = Nothing

intRow = 1

Do Until intRow = 200

strTab = CaseArray(intRow, 1)

GoSub check_tab

If blnProject = True Then
Set xlsApp = CreateObject("Excel.Application")
Set xlsWB1 = xlsApp.Workbooks.Open(strFileName)
Set xlsWS2 = xlsWB1.Worksheets(strTab)
GoSub import_tab
xlsWB1.Close
Set xlsWB1 = Nothing
Set xlsWS2 = Nothing
Set xlsApp = Nothing
End If

intRow = intRow + 1

Loop

Exit Function

check_tab: 'check to see if the cell value is valid project

blnProject = True

strSql = "SELECT Tab_Name FROM tbl_NonProject_Tabs WHERE Tab_Name
= " strSql = strSql & "'" & strTab & "'"

'tbl_NonProject_Tabs lists those tabs that are not real projects

Set rst1 = CurrentDb.OpenRecordset(strSql)
If rst1.EOF = False Then
blnProject = False 'if value is in table then not a
project rst1.Close
End If

If strTab = "" Then
blnProject = False 'if value is blank then not a project
End If

Return


check_new_proj: 'check to see if the project exists on database

blnNewP = False

strSql = "Select * FROM tbl_projects WHERE project_code = '"
strSql = strSql & strCell & "'"

Set rst1 = CurrentDb.OpenRecordset(strSql)

If rst1.EOF = True Then
blnNewP = True
End If
rst1.Close

Return

add_proj: 'add new project to database

Set rst2 = CurrentDb.OpenRecordset("tbl_projects", dbOpenDynaset)

rst2.AddNew
rst2![project_code] = strCell
rst2![project_description] = strCell2
rst2![Active] = True
rst2.Update

rst2.Close

Return


import_tab: 'read data from tab and add new data

strCell = xlsWS2.cells(2, 4).Value
strCell2 = xlsWS2.cells(2, 5).Value
GoSub check_new_proj 'check to see if project exists in
database If blnNewP = True Then
GoSub add_proj 'add project if project doesn't exist
End If
Return


End Function

In addition to Chris O'C's comments

Especially one part of the code is very ineffective, and might
probably prove to be/become a memory leak.

Within a loop, you are not only reopening the same workbook umpteen
times (umpteen being about 200, I think), but also reinstantiate
Excel. Seems to me you could do the following in stead - NOTE - also
remove the lines closing the workbook (xlsWB1) and releasing the
application (xlsApp) above

Do Until intRow = 200

strTab = CaseArray(intRow, 1)

GoSub check_tab

If blnProject = True Then
Set xlsWS2 = xlsWB1.Worksheets(strTab)
GoSub import_tab
Set xlsWS2 = Nothing
End If

intRow = intRow + 1

Loop

To read the limits of an Excel Range dynamicly, you can do something
like the following, for instance if you know the starting range of it,
or a cell within the range.

' First row
Debug.Print xlsWS2.Range("A4").CurrentRegion.Row
' First Column
Debug.Print xlsWS2.Range("A4").CurrentRegion.Column
' Number of rows
Debug.Print xlsWS2.Range("A4").CurrentRegion.Rows.Count
' number of columns
Debug.Print xlsWS2.Range("A4").CurrentRegion.Columns.Count
' LastRow
Debug.Print xlsWS2.Range("A4").CurrentRegion.Row - 1 + _
Debug.Print xlsWS2.Range("A4").CurrentRegion.Rows.Count

Or, for a loop, you could run until you reach an empty cell

do while not IsEmpty(xlsWS1.cells(row, col).Value)

One question though, which line does it error on?

 

[Tom S]

The index currently has about 80 rows, but I wanted to choose a higher number
to handle any future updates to the spreadsheet that add rows to the index.

The section where the actual data is loaded into the db isn't completed yet.
Since I was running into these errors on just reading the spreadsheet, I
hadn't fully written the actual data load section.

 

[RoyVidar]

The error occurs on the following line:

Set xlsWS2 = xlsWB1.Worksheets(strTab)

Typically when attempting to read the 3rd or 4th sheet in the
workbook. I realize that opening and closing is extremely
inefficient. I was thinking that the workbook being locked opened
was causing the error, so I was trying to close it each time.

I problaby don't understand completely what you mean with "locked
opened", or what you said initially "Access is locking the file open
when the code is run", but the subscript out of range, usually means
that there is noe sheet in the spesified workbook with the name you
specify.

You know how to debug? Hit F9 on the row you wish to inspect (set
breakpoint), then when it stops there, check out the values of the
different variables.

Or - just do a

debug.print strTab

just before the line where it stops, and pick up that value from the
immediate pane (ctrl+g)

If you now get the correct values, and it doesn't error, it might
mean that you have some kind of "race condition", where excel isn't
properly instantiated and/or the workbook not entirely open before
you attempt to assign one of it's sheet to a variable.

If it still errors, then the error might be within the code
assigning values to your two dimentional array, or it could for
instance be that either the sheet name contains spaces, or perhaps
what is stored in the first sheet contains spaces...

In stead of testing against a list in the first sheet, you could
also loop the sheets.

For Each xlsWS2 In xlsWB1.WorkSheets
Debug.Print xlsWS2.Name
Next xlsWS2

 

[Tom S]

What I mean by locked open is that even if I let the program complete by
skipping the error line in debug, when I attempt to open the spreadsheet, I
get the warning message that the spreadsheet is locked for editting and can
only be opened as read-only.

 

[RoyVidar]

What I mean by locked open is that even if I let the program complete
by skipping the error line in debug, when I attempt to open the
spreadsheet, I get the warning message that the spreadsheet is
locked for editting and can only be opened as read-only.

Some of the reasons for that, is probably among the stuff we have
already discussed, and perhaps also that you do not quit any of the
"umpteen" instances of Excel you're instantiating. How many instances
of Excel do you find in Task Manager (Ctrl+Shift+Esc)?

Here's a little attempt at rewriting the stuff a bit.

Sub rvsTesting()

Dim xl As Object
Dim wr As Object
Dim shIdx As Object
Dim sh As Object

Dim idx As Long
Dim SQL As String
Dim fxl As Boolean
Dim ffound As Boolean

Dim rs As DAO.Recordset
Dim db As DAO.Database

On Error Resume Next

' instantiate an xl object varible, utilizing
' open xl-instance if such exists
fxl = True
Set xl = GetObject(, "excel.application")
If Err.Number <> 0 Then
' excel not running, instantiate
Err.Clear
Set xl = CreateObject("excel.application")
If Err.Number <> 0 Then
' ouch - is xl installed at all???
Err.Clear
Exit Sub
End If
fxl = Not fxl
End If

On Error GoTo myerr

Set wr = xl.Workbooks.Open("c:\RLC.xls")
Set shIdx = wr.Sheets("Index")
idx = 1
Set db = CurrentDb

' main loop - walking through each cell in the A column of the
' index sheet until the last cell containing a value
Do While Not IsEmpty(shIdx.Range("A" & idx).Value)
SQL = "SELECT Tab_Name " & _
"FROM tbl_NonProject_Tabs " & _
"WHERE Tab_Name ='" & shIdx.Range("A" & idx).Value & "'"
Set rs = db.OpenRecordset(SQL)

ffound = rs.RecordCount > 0
rs.Close
Set rs = Nothing

If Not ffound Then
Set sh = wr.Worksheets(shIdx.Range("A" & idx).Value)
SQL = "SELECT * " & _
"FROM tbl_projects " & _
"WHERE project_code ='" & _
sh.Range("B4").Value & "'"
Set rs = db.OpenRecordset(SQL)

ffound = rs.RecordCount > 0
rs.Close
Set rs = Nothing

If Not ffound Then
SQL = "INSERT INTO tbl_projects " & _
"(project_code, project_description, Active) " &
_
"Values ('" & sh.Range("B4").Value & "', '" & _
sh.Range("B5").Value & "', -1)"
CurrentDb.Execute SQL, dbFailOnError
End If
End If
idx = idx + 1
Loop

myexit:
Set sh = Nothing
Set shIdx = Nothing
If Not wr Is Nothing Then
If Len(wr.Name) Then
wr.Close
End If
End If
Set wr = Nothing
If Not fxl Then
xl.Quit
End If
Set xl = Nothing
Exit Sub
myerr:
MsgBox Err.Description
Resume myexit
End Sub


But, but, but

There's no check for whether the sheet name is correctly spelled,
and/or that it exists (as I've mentioned could be one possible
reason for the "subscript out of range" error.

Set sh = Nothing
For Each shTest In wr.Worksheets
If shTest = shIdx.Range("A" & idx).Value
Set sh = shTest
Exit Do
End If
Next shTest

If Not sh Is Nothing Then
' Ah - the sheet exists...
End If

 

[Tom S]

Your code solves the "locking the file open" issue, but I am still getting
the subscript out of range error. The code is able to read the Index
worksheet and the first worksheet, but the error occurs on the next
worksheet. Both worksheet names have spaces in the names, so it doesn't
appear to the space in the worksheet name. If I skip that worksheet in
debug, the error occurs on the subsequent worksheets as well.

 

[RoyVidar]

Your code solves the "locking the file open" issue, but I am still
getting the subscript out of range error. The code is able to read
the Index worksheet and the first worksheet, but the error occurs on
the next worksheet. Both worksheet names have spaces in the names,
so it doesn't appear to the space in the worksheet name. If I skip
that worksheet in debug, the error occurs on the subsequent
worksheets as well.

And the line where it errors is the following?

Set sh = wr.Worksheets(shIdx.Range("A" & idx).Value)

If so, then the name in the first sheet differs from the name of
the actual sheet. In other word, a sheet with the name you have in
your index sheet, does not exist.

For instance, as I did in my smallish test yesterday (and right now),
having the name "my test project" as text in the index sheet, and
"my test project " as the actual name of the sheet - the difference
being that there's one additional space at the end of the sheet
name.

You have errors in your data. The list of sheets in your index sheet,
does not match the names of the actual sheets.

This I have commented on in the last two replies.

You need to find out how to deal with it, and my suggestion, as I've
alredy in my two last replies, is to loop through the actual sheets
and compare to your table in staed of having an out-of-sync list
of non-matching sheet names.

 

[Tom S]

Thanks for all your help, I had been running the debug and couldn't figure
out the difference between the name in the index and the name of the
worksheet. I finally figured out that the name in the index had an extra
space at the name of the worksheet (i.e. "worksheet2 " versus "worksheet2").
Changed the name in the Index and no error.

Thanks again for all your help.