AW: Access-Datenbank von Excel aus per VBA erzeugen
29.01.2018 13:12:30
Excel
Hallo Holger,
ich hab den folgenden Code mal irgendwo gefunden und abgespeichert. Guck mal ob es dir weiterhilft bzw. reicht.
Option Explicit
Const Datei As String = "C:\temp\vba_sql.mdb"
Sub in_DB_eine_Tabelle_anlegen()
Dim db As Database
Dim Antwort As Long
On Error GoTo Hell
Rem wenn Datei nicht vorhanden dann anlegen
If Dir(Datei) = "" Then
Set db = CreateDatabase(Datei, dbLangGeneral)
Else
Rem wenn alte Datei vorhanden nachfragen
Antwort = MsgBox("soll die alte Datei:" & vbNewLine _
& Datei & vbNewLine _
& "gelöscht werden?", vbYesNo, "Datei ist schon vorhanden")
If Antwort = 6 Then
Rem alte Datei löschen
Kill Datei
Rem neue Datei anlegen
Set db = CreateDatabase(Datei, dbLangGeneral)
Else
Rem falls Nein angeklickt dann aussteigen
MsgBox "keine Änderung vorgenommen", , "Abbruch"
Exit Sub
End If
End If
Rem DB öffnen
Set db = OpenDatabase(Datei)
Rem Tabelle "Personal" anlegen und Spalten einfügen
db.Execute ("Create table Personal" _
& "(PersonalNR SMALLINT NOT NULL, Name CHAR(40), Vorname char(40)," _
& "Geschlecht char(1), AbtNR SMALLINT, Eintritt DATE, Gehalt NUMERIC)")
Rem in Tabelle "Personal" Daten eintragen
db.Execute ("Insert into Personal Values" _
& "(5,'Schröder','Heinz','M',2, #61-05-15#,2500.00)")
db.Execute ("Insert into Personal Values" _
& "(8,'Schneider','Sybille','W',3, DateValue('1.5.79'),4200.00)")
Set db = Nothing
MsgBox "Daten eingetragen", , Datei
Exit Sub
Hell:
Set db = Nothing
MsgBox "FehlerNr.: " & Err.Number & vbNewLine & vbNewLine _
& "Beschreibung: " & Err.Description _
, vbCritical, "Fehler aufgetreten"
End Sub
Sub DatenübernahmeNachExcel()
' unbedingt Verweis auf ActiveX Data Objects setzen
Dim ADOC As New ADODB.Connection
Dim DBS As New ADODB.Recordset
Dim cmd As ADODB.Command
On Error GoTo Fehlerbehandlung
ADOC.Open "Provider=Microsoft.Jet.oledb.4.0;data source=C:\temp\vba_sql.mdb;"
DBS.Open "Personal", ADOC, adOpenKeyset, adLockOptimistic
Set cmd = New ADODB.Command
cmd.CommandText = "Select * from Personal"
cmd.ActiveConnection = ADOC
Set DBS = cmd.Execute
Sheets("Tabelle1").Activate
Range("A2").Select
Do While Not DBS.EOF
ActiveCell.Value = DBS!PersonalNR
ActiveCell.Offset(0, 1).Value = DBS!Name
ActiveCell.Offset(0, 2).Value = DBS!Vorname
ActiveCell.Offset(0, 3).Value = DBS!Geschlecht
ActiveCell.Offset(0, 4).Value = DBS!AbtNR
ActiveCell.Offset(0, 5).Value = DBS!Eintritt
ActiveCell.Offset(0, 6).Value = DBS!Gehalt
DBS.MoveNext
ActiveCell.Offset(1, 0).Select
Loop
Columns("A:J").AutoFit
DBS.Close
ADOC.Close
Set DBS = Nothing
Set ADOC = Nothing
Set cmd = Nothing
Exit Sub
Fehlerbehandlung:
MsgBox "Es ist ein Fehler aufgetreten!" & Chr(13) & Err.Description
DBS.Close
ADOC.Close
Set ADOC = Nothing
Set DBS = Nothing
End Sub
Beste Grüße
chaosoft