Exceldaten nach Accsess
adi
es bestehen zwei identische Dateien, ein Excel und eine Access Datei.
In der jetzigen Version sind zehn Spalten belegt und alles funktioniert
sehr gut. Die Daten werden von den unten stehenden Code von Excel nach Access übertragen.
Ich möchte nun die Dateien um zehn Spalten erweitern, so dass ich dann zwanzig Spalten habe.
Eine Zeit lang versuche ich das Problem zu lösen, aber es geht nicht, dazu fehlen mir die Kenntnisse.
Der Fehler tritt schon auf, wenn ich nur eine Spalte dazu nehme. Unten im Code habe ich
ein Beispiel markiert wo der kompilierungs Fehler auftritt.
Hoffentlich habe ich das Problem verständlich beschrieben.
Würde mich sehr über eine Antwort freuen.
Im übrigen habe ich vor einigen Tagen schon einmal hier angefragt und danach beide Dateien
hoch geladen, aber leider keine verwertbare Rückmeldung bekommen.
Option Explicit
Sub CreateNewAccessDB(Optional Access2003 As Boolean = True)
Dim adoxCatalog As New ADOX.Catalog
Dim adoxTable As New ADOX.Table
Dim xCol As New ADOX.Column
Dim adoRecordset As ADODB.Recordset
Dim adoConnection As ADODB.Connection, txt As String
Dim cmd As ADODB.Command
Dim strFile1 As String, strFile2 As String, strTable As String
Dim adoxProvider As String, lngRow As Long, lngCol As Long, lngRowMax As Long
Dim objSource As Worksheet
Const adOpenKeyset As Long = 1
Const adLockOptimistic As Long = 3
strFile1 = "Adressen_Export.mdb"
strFile2 = ThisWorkbook.Path & "\" & strFile1
'Tabellenname in Access Datenbank
strTable = "KGV"
'Quelldaten
Set objSource = ThisWorkbook.Worksheets("KGV")
If "" Dir(strFile2, vbNormal) Then
Kill strFile2
End If
Set adoxCatalog = New ADOX.Catalog
'ADO-Objekte erzeugen
Set adoConnection = New ADODB.Connection
Set adoRecordset = New ADODB.Recordset
If Access2003 Then
' Access 2003 Datenbank erzeugen (.mdb)
adoxProvider = "Microsoft.Jet.OLEDB.4.0"
lngRowMax = 65536
' Else
'Access 2007 Datenbank erzeugen (.accdb)
' adoxProvider = "Microsoft.ACE.OLEDB.12.0"
' lngRowMax = 1000000
End If
adoConnection.Provider = adoxProvider
adoxProvider = "Provider=" & adoxProvider
'Dateiort und Name der Zieldatei festlegen
adoxCatalog.Create adoxProvider & ";Data Source=" & strFile2
adoxCatalog.ActiveConnection = adoxProvider & ";Data Source=" & strFile2
Set adoxTable = New ADOX.Table
With adoxTable
.Name = strTable
.ParentCatalog = adoxCatalog
'Felder anlegen
Set xCol = New ADOX.Column
With xCol
.Name = "Garten_Nr"
.Type = adVarWChar
End With
.Columns.Append xCol
With xCol
.Properties("Nullable").Value = True
.Properties("Jet OLEDB:Allow Zero Length") = True
End With
Set xCol = New ADOX.Column
With xCol
.Name = "Anrede"
.Type = adVarWChar
.DefinedSize = 30
End With
.Columns.Append xCol
With xCol
.Properties("Nullable").Value = True
.Properties("Jet OLEDB:Allow Zero Length") = True
End With
Set xCol = New ADOX.Column
With xCol
.Name = "Vorname"
.Type = adVarWChar
.DefinedSize = 30
End With
.Columns.Append xCol
With xCol
.Properties("Nullable").Value = True
.Properties("Jet OLEDB:Allow Zero Length") = True
End With
Set xCol = New ADOX.Column
With xCol
.Name = "Nachname"
.Type = adVarWChar
.DefinedSize = 30
End With
.Columns.Append xCol
With xCol
.Properties("Nullable").Value = True
.Properties("Jet OLEDB:Allow Zero Length") = True
End With
Set xCol = New ADOX.Column
With xCol
.Name = "Strasse"
.Type = adVarWChar
.DefinedSize = 30
End With
.Columns.Append xCol
With xCol
.Properties("Nullable").Value = True
.Properties("Jet OLEDB:Allow Zero Length") = True
End With
Set xCol = New ADOX.Column
With xCol
.Name = "Ort"
.Type = adVarWChar
.DefinedSize = 30
End With
.Columns.Append xCol
With xCol
.Properties("Nullable").Value = True
.Properties("Jet OLEDB:Allow Zero Length") = True
End With
Set xCol = New ADOX.Column
With xCol
.Name = "Telefon"
.Type = adVarWChar
.DefinedSize = 30
End With
.Columns.Append xCol
With xCol
.Properties("Nullable").Value = True
.Properties("Jet OLEDB:Allow Zero Length") = True
End With
Set xCol = New ADOX.Column
With xCol
.Name = "Geboren"
.Type = adDate
End With
.Columns.Append xCol
With xCol
.Properties("Nullable").Value = True
.Properties("Jet OLEDB:Allow Zero Length") = True
End With
Set xCol = New ADOX.Column
With xCol
.Name = "Eintritt"
.Type = adDate
End With
.Columns.Append xCol
With xCol
.Properties("Nullable").Value = True
.Properties("Jet OLEDB:Allow Zero Length") = True
End With
Set xCol = New ADOX.Column
With xCol
.Name = "KWh"
.Type = adVarWChar
.DefinedSize = 30
End With
.Columns.Append xCol
With xCol
.Properties("Nullable").Value = True
.Properties("Jet OLEDB:Allow Zero Length") = True
End With
End With
' z.B. Wenn ich diesen Code eingebe, kommt sofort Kompilierung Fehler,
' Bei Columns.Append xCol
' Set xCol = New ADOX.Column
' With xCol
' .Name = "KWh_Verbrauch"
' .Type = adVarWChar
' .DefinedSize = 30
' End With
' .Columns.Append xCol
' With xCol
' .Properties("Nullable").Value = True
' .Properties("Jet OLEDB:Allow Zero Length") = True
' End With
' End With
adoxCatalog.Tables.Append adoxTable
Set adoxCatalog = Nothing
Set adoxTable = Nothing
Set adoxCatalog = Nothing
' Verbindung zur Datenbank herstellen
adoConnection.Open "Data Source=" & strFile2, UserId:="", Password:=""
' Datenbank auslesen
adoRecordset.Open "SELECT * FROM [" & strTable & "]", _
adoConnection, adOpenKeyset, adLockOptimistic
' Mit Daten aus Blatt Quelldaten füllen
With adoRecordset
For lngRow = 2 To objSource.Cells(lngRowMax, 1).End(xlUp).Row
.AddNew ' Neuer Datensatz
For lngCol = 1 To 10
.Fields(lngCol - 1) = objSource.Cells(lngRow, lngCol)
Next
.Update ' Datenbank aktualisieren
Next
End With
' Schließen
adoRecordset.Close
Set adoRecordset = Nothing
adoConnection.Close
Set adoConnection = Nothing
MsgBox "Datenbankdatei:" & vbCrLf & strFile1 & vbCrLf & _
"erfolgreich angelegt"
Exit Sub
ErrorHandler:
MsgBox "Fehlermeldung Original:" & vbCrLf & Err.Description _
& vbCrLf & vbCrLf & _
"Eventuell Fehler beim Anlegen der Datei" & vbCrLf & _
strFile1 & vbCrLf & _
"Laufwerk möglicherweise Schreibgeschützt (CD)"
On Error Resume Next
Set adoxTable = Nothing
Set adoxCatalog = Nothing
adoRecordset.Close
Set adoRecordset = Nothing
adoConnection.Close
Set adoConnection = Nothing
End Sub
adi