Import multiple XL worksheets

[Jason Morin]

Hello. Using Access 2003. I'd like to create a simple
macro that imports multiple worksheets of identical
format (headers in row 1) from an XL file into the same
Access table. Something like:

Sub ImportXL()
For each <Excel worksheet> in <Excel filename and path>
Docmd.TransferSpreadsheet ,,"PG","C:\My" & _
"Documents\PG.xls",TRUE,)
Next
End Sub

Assume empty table in Access is already set up with the
correct field names.
Any direction on how to do this would be appreciated. Thx!
Jason

 

[Jamie Collins]

Something like:

Sub ImportXL()
For each <Excel worksheet> in <Excel filename and path>
Docmd.TransferSpreadsheet ,,"PG","C:\My" & _
"Documents\PG.xls",TRUE,)
Next
End Sub

Assume empty table in Access is already set up with the
correct field names.

Something like:

INSERT INTO MyTable
(MyKeyCol, MyDataCol)
SELECT
MyKeyCol, MyDataCol
FROM
[Excel 8.0;HDR=YES;Database=C:\MyDocuments\PG.xls;].[Sheet1$]
UNION ALL
SELECT
MyKeyCol, MyDataCol
FROM
[Excel 8.0;HDR=YES;Database=C:\MyDocuments\PG.xls;].[Sheet2$]
UNION ALL
SELECT
MyKeyCol, MyDataCol
FROM
[Excel 8.0;HDR=YES;Database=C:\MyDocuments\PG.xls;].[Sheet3$]
;

If you don't have the list of worksheet names:

Public Function GetWSNames( _
ByVal WBPath As String _
) As Variant
Dim adCn As Object
Dim adRs As Object
Dim asSheets() As String
Dim nShtNum As Long
Dim nRows As Long
Dim nRowCounter As Long
Dim sSheet As String
Dim sOSheet As String
Dim sChar1 As String
Dim sChar2 As String

Const INDICATOR_SHEET As String = "$"
Const INDICATOR_SPACES As String = "'"

Set adCn = CreateObject("ADODB.Connection")

With adCn
.ConnectionString = "Provider=Microsoft.Jet.OLEDB" & _
".4.0;Data Source=" & WBPath & ";Extended " & _
"Properties='Excel 8.0;HDR=Yes'"
.CursorLocation = 3
.Open
End With

Set adRs = adCn.OpenSchema(20)
With adRs

nRows = .RecordCount
Dim strMsg As String
For nRowCounter = 0 To nRows - 1
sOSheet = !TABLE_NAME
strMsg = "[" & sOSheet & "]"
sSheet = !TABLE_NAME
sChar1 = vbNullString
sChar2 = vbNullString
On Error Resume Next
sChar1 = Mid$(sSheet, Len(sSheet), 1)
sChar2 = Mid$(sSheet, Len(sSheet) - 1, 1)
On Error GoTo 0

Select Case sChar1

Case INDICATOR_SHEET
sSheet = Left$(sSheet, Len(sSheet) - 1)

Case INDICATOR_SPACES
If sChar2 = INDICATOR_SHEET Then
sSheet = Mid$(sSheet, 2, Len(sSheet) - 3)
End If

Case Else
sSheet = vbNullString

End Select

If Len(sSheet) > 0 Then
ReDim Preserve asSheets(nShtNum)

' Un-escape
asSheets(nShtNum) = Replace(sSheet, _
INDICATOR_SPACES & INDICATOR_SPACES, _
INDICATOR_SPACES)
strMsg = strMsg & "=[" & sSheet & "]"
nShtNum = nShtNum + 1
End If

.MoveNext
Next
.Close
End With
adCn.Close

GetWSNames = asSheets

End Function


Jamie.

--