Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Access-Datenbank von Excel aus per VBA erzeugen


Betrifft: Access-Datenbank von Excel aus per VBA erzeugen von: Holger_M
Geschrieben am: 29.01.2018 12:42:35

Hallo an die Excel-VBA-Spezialisten,

vor ein paar Tagen wurde hier nach der Möglichkeit gefragt, eine Firebird-Datenbank per VBA zu erzeugen. Ich suche für ein in Excel zu realisierendes Projekt nach einer solchen Möglichkeit, allerdings für eine Access-Datenbank. Leider gab es als Antwort auf die erwähnte Frage nur die Idee, die Datenbank per Kopie aus einer leeren Datenbank zu erzeugen. Das geht natürlich immer, ich würde aber gern per VBA eine neue Datenbank erzeugen. Hat jemand eine Idee, wie man das machen könnte?

Viele Grüße
Holger_M

  

Betrifft: AW: Access-Datenbank von Excel aus per VBA erzeugen von: chao.soft
Geschrieben am: 29.01.2018 13:12:30

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


  

Betrifft: AW: Access-Datenbank von Excel aus per VBA erzeugen von: ChrisL
Geschrieben am: 29.01.2018 13:17:05

Hi Holger

Hier eine Variante (Late Binding)

Sub t()
Dim objAccess As Object
Dim objDB As Object, strDB As String
Dim objTable As Object, strTable As String
Dim objFeld As Object, strFeld As String

Set objAccess = CreateObject("Access.Application")

strDB = ThisWorkbook.Path & "\Newdb.mdb"
strTable = "Tabelle1"
strFeld = "MeineSpalte"
    
objAccess.NewCurrentDatabase strDB
Set objDB = objAccess.currentDB
Set objTable = objDB.CreateTableDef(strTable)
Set objFeld = objTable.CreateField(strFeld, 10, 40)

objTable.Fields.Append objFeld
objDB.TableDefs.Append objTable

Set objAccess = Nothing
Set objTable = Nothing
Set objFeld = Nothing
End Sub

cu
Chris


  

Betrifft: Diese Frage hatten... von: Case
Geschrieben am: 29.01.2018 14:20:07

Hallo, :-)

... wir gerade vor ein paar Tagen: ;-)

Dankenbanken erzeugen...

Servus
Case



  

Betrifft: AW: Access-Datenbank von Excel aus per VBA erzeugen von: Dieter Klemke
Geschrieben am: 29.01.2018 18:01:19

Hallo Holger,

ich habe hier noch eine Lösung, bei der du Access nicht starten musst. Du brauchst Verweise auf die Bibliotheken ADODB und ADOX (Microsoft ActiveX Data Objects x.y Library und Microsoft ADO Ext. x.y for DDL and Security):

Sub Datenbank_erzeugen()
 
  Dim anzSätze As Long
  Dim cat As ADOX.Catalog
  Dim col As ADOX.Column
  Dim con As ADODB.Connection
  Dim datei As String
  Dim dauer As Single
  Dim i As Long
  Dim idx As ADOX.Index
  Dim k As Long
  Dim pfad As String
  Dim rs As ADODB.Recordset
  Dim tbl As ADOX.Table
  Dim zf As String
  
  Application.StatusBar = False
  anzSätze = 50
  dauer = Timer
  pfad = ThisWorkbook.Path & "\"
  datei = "NetzTestDB.accdb"
  '++++++++++++++++++++++++++++++++++++++++++++++++
  ' Eine eventueel vorhandene Datenbank vorsorglich
  ' löschen
  '++++++++++++++++++++++++++++++++++++++++++++++++
  On Error Resume Next
  Kill pfad & datei
  On Error GoTo 0
  '++++++++++++++++++++++++++++++++++++++++++++++++
  ' Datenbank neu anlegen (Tabelle "Zugriffe" und Felder)
  '++++++++++++++++++++++++++++++++++++++++++++++++
  Set cat = New ADOX.Catalog
  cat.Create "Provider=Microsoft.Jet.OLEDB.4.0;" & _
             "Data Source=" & pfad & datei
  Set tbl = New ADOX.Table
  tbl.Name = "Zugriffe"
  tbl.Columns.Append "IdentNr", adInteger
  tbl.Columns.Append "GenName", adVarWChar, 9
  tbl.Columns.Append "ZugriffsSaldo", adInteger
  For i = 1 To 15
    zf = "PC" & Format$(i, "00") & "_Name"
    tbl.Columns.Append zf, adVarWChar, 16
    tbl.Columns(2 * i + 1).Attributes = adColNullable
    zf = "PC" & Format$(i, "00") & "_AnzZugr"
    tbl.Columns.Append zf, adInteger
  Next i
  ' Index anfügen
  Set idx = New ADOX.Index
  idx.Name = "PrimaryKey"
  idx.Columns.Append "IdentNr"
  tbl.Indexes.Append idx
  
  cat.Tables.Append tbl
  Set cat = Nothing
  '++++++++++++++++++++++++++++++++++++++++++++++++
  ' Datenbank mit der gewünschten Anzahl Sätze füllen
  '++++++++++++++++++++++++++++++++++++++++++++++++
  Set con = New ADODB.Connection
  con.Open ConnectionString:= _
              "Provider=Microsoft.Jet.OLEDB.4.0;" & _
              "Data Source=" & pfad & datei
  Set rs = New ADODB.Recordset
  rs.Open Source:="Zugriffe", _
          ActiveConnection:=con, _
          CursorType:=adOpenKeyset, _
          LockType:=adLockOptimistic, _
          Options:=adCmdTableDirect
  Randomize
  For i = 1 To anzSätze
    ' Anfangsbuchstabe des generierten Namens (Großschreibung)
    zf = Chr(Fix(26 * Rnd()) + 65)
    For k = 1 To 8
      ' Folgebuchstaben des generierten Namens (Kleinschreibung)
      zf = zf & Chr(Fix(26 * Rnd()) + 97)
    Next k
    rs.AddNew
    rs!IdentNr = i
    rs!GenName = zf
    rs!zugriffssaldo = 0
    For k = 1 To 15
      rs(2 * k + 2) = 0
    Next k
    rs.Update
    Application.StatusBar = "Satz: " & i
  Next i
  
  '++++++++++++++++++++++++++++++++++++++++++++++++
  ' Abschlußarbeiten
  '++++++++++++++++++++++++++++++++++++++++++++++++
  rs.Close
  Set rs = Nothing
  con.Close
  Set con = Nothing
  dauer = Timer - dauer
  Application.StatusBar = Empty
  MsgBox Prompt:="Datenbank" & vbNewLine & vbNewLine & _
                 pfad & datei & vbNewLine & vbNewLine & _
                 "mit " & anzSätze & " Sätzen neu erzeugt!" & vbNewLine & vbNewLine & _
                 "Zeitdauer: " & Format$(dauer, "#,##0.0 \S\e\k\."), _
         Buttons:=vbInformation
End Sub
Viele Grüße
Dieter


  

Betrifft: AW: Access-Datenbank von Excel aus per VBA erzeugen von: Holger_M
Geschrieben am: 29.01.2018 22:09:27

Hallo chao.soft, Chris, Case und Dieter,

herzlichen Dank für eure Lösungen. Sie funktionieren alle 4 einwandfrei. Für mich sind die drei Lösungen besonders interessant, die nicht voraussetzen, dass Access installiert ist. Ich werde die Lösungen in Ruhe analysieren und mir dann die zu meinem Problem am besten passende aussuchen.

Nochmals besten Dank und viele Grüße
Holger_M


Beiträge aus dem Excel-Forum zum Thema "Access-Datenbank von Excel aus per VBA erzeugen"