I have the project that may never end in front of me.
I am creating a routine that will take SpreadSheets from Excel and
bring them into Access.
I am not using any "DoCmd"s because the goal is for the import code
to be moved to a stand alone VB app which will use the Access DB as a
workspace to process the data from the spreadsheets. Quite honestly,
done right this may not even require Access or Excel to be on the
users machine. Right now all code and testing occurs in Access.
The code I use to bring the sheets into Access looks like:
Public rsTable As ADODB.Recordset
Public strSheet As String
Public StrExceptionReason As String
Public coListOfExcelTables As New Collection
Private cnMvConnection As ADODB.Connection
Private strPath As String
Sub ImportMembers()
Dim i As Integer
Dim j As Integer
Dim cat As ADOX.Catalog
Set cat = New ADOX.Catalog
'The folowing is here for testing - replace with your Path & File.
'I use split and an array because I will need to process many Excel
files at once.
'They will be passed to the final executable "command line style."
strTableName = "X:\MBS_JOBS\71228A\71228ASHIPPER.XLS"
aryShippers = Split(strTableName, " ")
For i = 0 To (CInt(UBound(aryShippers)) -
CInt(LBound(aryShippers)))
strPath = aryShippers(i)
Connect (strPath)
GetExcelTables
For j = 1 To coListOfExcelTables.Count
'I add "xl_" to the tables name so I can separate them
from other
'tables which I have in the DB (helps during testing).
strSheet = "xl_" & coListOfExcelTables(j)
GetExcelData
MakeRowsUnique
'Do LOTS of other stuff - so I can get what I need, change
what needs
'to change and store the results in a pre-existing table
in this DB.
Next
cat.ActiveConnection = CurrentProject.Connection
For j = 1 To coListOfExcelTables.Count
' Delete the table, if it exists - to make way for the
next set
' of Sheets from the next file..
On Error Resume Next
cat.Tables.Delete "xl_" & coListOfExcelTables(j)
'cat.Tables.Refresh
Next
Next
cnMvConnection.Close
Set cnMvConnection = Nothing
End Sub
Private Function Connect(ByVal strFullPathToExcelSpreadsheet As
String) As Boolean
'Make and open a connection to a given Excel spreadsheet
Set cnMvConnection = New ADODB.Connection
With cnMvConnection
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" &
strFullPathToExcelSpreadsheet _
& ";Extended Properties=Excel 8.0;"
.Open
End With
End Function
Private Function GetExcelTables()
'Get a list of tables available in the Excel spreadsheet which was
opened in the "Connect" function
Dim rs As ADODB.Recordset
Dim iTableNumber As Integer: iTableNumber = -1
Set coListOfExcelTables = New Collection
Set rs = New ADODB.Recordset
'Use the ADODB.Connection.OpenSchema method to get the structure
of the Excel spreadsheet
With cnMvConnection
Set rs = .OpenSchema(adSchemaTables)
End With
With rs
Do While Not .EOF
iTableNumber = iTableNumber + 1
'The TABLE_NAME field gives the name of the Table (Sheet).
'Thanks go out to Aceto De'Fabul, Utter Access VIP for
help
'getting Excel Spreadsheets with multi-word names to
import.
'As the code is here it will pull in every single Sheet as
a
'table, but not "PrintArea"s
If Right(.Fields("TABLE_NAME").Value, 10) <"Print_Area"
Then
If Left(.Fields("TABLE_NAME").Value, 1) = "'" Then
'Name of Sheet is two or more words.
coListOfExcelTables.Add
(Mid(.Fields("TABLE_NAME").Value, 2, _
(InStrRev(.Fields("TABLE_NAME").Value, "'") -
3)))
Else
'Name of Sheet is one word.
coListOfExcelTables.Add
(Left(.Fields("TABLE_NAME").Value, _
Len(.Fields("TABLE_NAME").Value) - 1))
End If
End If
.MoveNext
Loop
.Close
End With
Set rs = Nothing
End Function
Private Function GetExcelData() As ADODB.Recordset
Dim strSQL As String
'I have a specific range of data I need to collect - A11:I90
strSQL = "SELECT * INTO [" & strSheet & "] " & _
"FROM [Excel 8.0;HDR=Yes;database=" & strPath & ";].[" &
_
Right(strSheet, Len(strSheet) - 3) & "$A11:I90];"
CurrentProject.Connection.Execute strSQL
Application.RefreshDatabaseWindow
End Function
Private Function MakeRowsUnique()
'Add an autonumber column to ENSURE Row uniqueness.
' If you don't need it just Rem the call to it above.
Set f = CurrentDb.TableDefs(strSheet).CreateField("Unique" ,
dbLong)
f.Attributes = f.Attributes + dbAutoIncrField
f.OrdinalPosition = 0
CurrentDb.TableDefs(strSheet).Fields.Append f
End Function
This code is FAST, by the way. I am able to import the Sheets I need
from several Workbooks in the time it would take to do one using the
old Row-by-Row method that I continue to run into during searches on
the net.
Speed is important in what I am trying to do I have a lot that I need
to do - not shown here.
So what is the problem? Simple really - I need to know how to modify
the code above so that I only import a certain Sheet only if it is not
hidden.
Any suggestions?
