Von Excel auf Acces: Genauigkeitsangabe ungültig
09.08.2018 21:16:59
Marco
ich arbeite an folgenden Projekt: Per Makro sollen aus Excel heraus vorgefertigten Datentabellen in eine Access-Datenbank kopiert werden. Dafür bediene ich mich folgenden Beispiel: http://www.datawright.com.au/excel_resources/excel_access_and_ado_part_1.htm
Im ersten Schritt will ich die Datenbank anlegen. Dafür muss ich obiges Beispiel bei zwei Aspekten anpassen:
1. Es müssen die richtigen Worksheets mit den Tabellen automatisch erkannt werden. Die richtigen Sheets fangen mit 'DB' an.
2. Es müssen die Feldnamen vom jedem 'DB'-Sheet automatisch ausgelesen und in access angelegt werden sowie das richtige Dateiformat. Die Datentabellen sind bereits im "access"-freundlichen Export-/Importformat (1. Reihe Feldnamen, ab 2. Reihe Werte, keine Sonderzeichen außer Unterstrich(_)).
Es sind insgesamt 29 Worksheets und 6 bis 21 Spalten, deshalb soll das anlegen etc über die Schleifen erfolgen.
Per Debug.Print konnte ich sehen, dass beim ersten Durchgang (also erste Tabelle) der Name der Tabelle richtig ist sowie die Feldnamen mitsamt Format.
Eine Fehlermeldung erhalte ich dann hier:
cat.Tables.Append tbl
Fehlermeldung:
"Laufzeitfehler '-2147217862(80040e3a)': Die Genauigkeitsangabe ist ungültig"
Ich konnte zu diesen Problem nichts finden, hoffe ihr könnt mir helfen.
Code:
Option Explicit
Const TARGET_DB = "DBxtra1001.accdb"
Sub CreateDB_And_Table()
Dim cat As ADOX.Catalog
Dim tbl As ADOX.Table
Dim sDB_Path As String
sDB_Path = ActiveWorkbook.Path & Application.PathSeparator & TARGET_DB
'delete the DB if it already exists
On Error Resume Next
Kill sDB_Path
On Error GoTo 0
'get all relevant database worksheet names (starting with DB)
Dim SheetNameCol As Collection
Set SheetNameCol = New Collection
Dim tempName As String
Dim j, i, k As Integer
j = 0
For i = 1 To Sheets.Count
tempName = Left(Sheets(i).Name, 2)
If tempName = "DB" Then
j = j + 1
SheetNameCol.Add Sheets(i).Name
End If
Next i
'create the new database
Set cat = New ADOX.Catalog
cat.Create _
"Provider=Microsoft.ACE.OLEDB.12.0;" & _
"Data Source=" & sDB_Path & ";"
Dim m, x, ColNumber As Integer
Dim temp1 As String
Dim temp2 As Variant
Dim FieldNameCol As Collection
Set FieldNameCol = New Collection
For m = 1 To SheetNameCol.Count
'create the table
Set tbl = New ADOX.Table
'give new access-table same name as in excel
tbl.Name = SheetNameCol(m)
'get number of fields of current excel-table
ColNumber = FieldNameNumber(SheetNameCol(m))
'get field names and determine data type
For x = 1 To ColNumber
'get field names
temp1 = ActiveWorkbook.Worksheets(SheetNameCol(m)).Cells(1, x).Value
FieldNameCol.Add temp1
'determine cell format
Set temp2 = ActiveWorkbook.Worksheets(SheetNameCol(m)).Cells(2, x)
tbl.Columns.Append FieldNameCol(x), FieldDataType(temp2)
Next x
'append the newly defined table to the Tables collection in the database
cat.Tables.Append tbl
Next m
Set cat = Nothing
'now create the primary key
'Call CreatePrimaryKey("tblTransationHistory", "Zeit-ID")
End Sub
Private Function FieldNameNumber(SheetNameCol As String) As Integer
FieldNameNumber = ActiveWorkbook.Worksheets(SheetNameCol).UsedRange.Columns.Count
End Function
Function FieldDataType(temp2 As Variant) As String
Select Case True
Case IsNumeric(temp2): FieldDataType = adNumeric
Case IsDate(temp2): FieldDataType = adDate
Case Else: FieldDataType = adVarWChar
End Select
End Function