exporting multiple excel workbook with different names into access database

ayla-mamesh 

Hi Ayla,

here is a code from my german vba tanker. I think you can adopt it to your task.

Sub DatenAusExcelTabelleHinzufügen()
Dim conn As New ADODB.Connection
Dim rst As ADODB.Recordset
Dim objXlApp As Object
Dim objMappe As Object
Dim intZ As Integer

On Error GoTo Fehler
Set objXlApp = CreateObject("Excel.Application")
Set objMappe = objXlApp.workbooks.Open(Application.CurrentProject.Path _
& "\Mitarbeiter.xls")

Set conn = CurrentProject.Connection
Set rst = New ADODB.Recordset

rst.Open "Personal", conn, adOpenKeyset, _
adLockOptimistic

For intZ = 2 To objMappe.sheets("Personal").usedrange.rows.Count
With rst
.AddNew
.Fields("Nachname") = objMappe.sheets(1).cells(intZ, 2).Value
.Fields("Vorname") = objMappe.sheets(1).cells(intZ, 3).Value
.Fields("Position") = objMappe.sheets(1).cells(intZ, 4).Value
.Fields("Anrede") = objMappe.sheets(1).cells(intZ, 5).Value
.Fields("Geburtsdatum") = objMappe.sheets(1).cells(intZ, 6).Value
.Fields("Einstellung") = objMappe.sheets(1).cells(intZ, 7).Value
.Fields("Straße") = objMappe.sheets(1).cells(intZ, 8).Value
.Fields("Ort") = objMappe.sheets(1).cells(intZ, 9).Value
.Fields("Region") = objMappe.sheets(1).cells(intZ, 10).Value
.Fields("PLZ") = objMappe.sheets(1).cells(intZ, 11).Value
.Fields("Land") = objMappe.sheets(1).cells(intZ, 12).Value
.Update
End With
Next intZ

rst.Close
objMappe.Close
objXlApp.Quit

Set objMappe = Nothing
Set objXlApp = Nothing
Set rst = Nothing
Set conn = Nothing
Exit Sub

Fehler:
MsgBox Err.Number & " " & Err.Description
Set objMappe = Nothing
Set objXlApp = Nothing
End Sub

Best regards from germany

Bernd

http://www.vba-tanker.com