AW: per VBA mit Excel in Accesdatenbank schreiben
19.11.2018 16:18:58
JoWE
Hallo Werner,
ich hab's mal probiert:
Public jn As Boolean
Sub Aufruf()
' Beispielaufruf - Argumente
' 1) Pfad Excel-Arbeitsmappe
' 2) Pfad Access-Datenbank
' 3) Quell-Arbeitsblatt 1
' 4) Ziel-Tabelle 1
' bei Bedarf beliebige Paare ergänzen
' 5) Quell-Arbeitsblatt 2
' 6) Ziel-Tabelle 2
Call ExportToAccess1( _
ActiveWorkbook.Path & "\Erfassung mit Datenbank.xlsm", _
ActiveWorkbook.Path & "\Daten.mdb", _
"Schichten", "Schichten")
End Sub
Sub ExportToAccess1(strXLS As String, strMDB As String, ParamArray strTabellen() As Variant)
' Das erste Argument ist hier verzichtbar, könnte aber verwendet werden, die Arbeitsblätter
' einer zusätzlichen Arbeitsmappe zu exportieren (Eröffnung einer zusätzlichen Instanz -
' hier nicht enthalten)
' Verweis auf Microsoft DAO 3.6 Object Library
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim sh As Worksheet
Dim i As Long
Dim j As Long
Dim k As Long
Dim strXL As String
Set db = OpenDatabase(strMDB)
For i = 0 To UBound(strTabellen) - 1 Step 2
Set rs = db.OpenRecordset(strTabellen(i + 1))
Set sh = ActiveWorkbook.Worksheets(strTabellen(i))
' Accesstabelle leeren
'Do While Not rs.EOF
' rs.Delete
' rs.MoveNext
'Loop
' Datensätze anfügen
For j = 2 To sh.Cells(Cells.Rows.Count, 1).End(xlUp).Row
strXL = "|" & Cells(j, 2).Value & "|" & Format(Cells(j, 3), "DD.MM.YYYY") & "|" & _
Format(Cells(j, 4), "hh:mm:ss") & "|" & Format(Cells(j, 5), "DD.MM.YYYY") & "|" & _
Format(Cells(j, 6), "hh:mm:ss")
Call checkDS(strXL)
rs.AddNew
' Feld rs(0) enthält ID (Autowert) und wird in der Schleife ausgelassen
For k = 1 To rs.Fields.Count - 1
rs(k) = sh.Cells(j, k)
Next k
rs.Update
Next j
rs.Close
Next i
db.Close
Set rs = Nothing
Set sh = Nothing
Set db = Nothing
' Sheets("Schichten").Unprotect
' Sheets("Schichten").UsedRange.ClearContents
End Sub
'Const strFileName As String = "C:\Users\Jochen\Downloads\herber\Daten.mdb"
Sub checkDS(strXL As String)
Dim rcsEntry As Object
Dim objConn As Object
On Error GoTo Fin
Set objConn = CreateObject("ADODB.Connection")
Set rcsEntry = CreateObject("ADODB.Recordset")
With objConn
.CursorLocation = 3 ' = adUseClient
' "Microsoft.Jet.OLEDB.4.0"
.Provider = "Microsoft.ACE.OLEDB.12.0"
.Properties("Data Source") = "C:\Users\Jochen\Downloads\herber\Daten.mdb"
.Open
End With
With rcsEntry
.ActiveConnection = objConn
.CursorLocation = 3 ' = adUseClient
.LockType = 3 ' = adLockOptimistic
.CursorType = 1 ' = adOpenKeyset
' Name ist die Bezeichnung der Tabelle
.Source = "SELECT * FROM Schichten"
.Open
If .RecordCount 0 Then
.MoveFirst
End If
ze = 7
Do Until .EOF
For f = 2 To 6
'Cells(ze, 2).Value = Cells(ze, 2).Value & "|" & .Fields(f).Value
strDB = strDB & "|" & .Fields(f).Value
Next
If strDB = strXL Then
jn = True
Exit Sub
Else
jn = False
End If
ze = ze + 1
.MoveNext
Loop
End With
Fin:
If Err.Number 0 Then MsgBox "Fehler: " & _
Err.Number & " (" & Err.Description & ")"
If Not objConn Is Nothing And objConn.State = 1 Then objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
End Sub
Gruß
Jochen