ACCESS DB aus VB updaten

[whisky1108]

Hallo Leute,

ich möchte meine Access DB für mein in VB geschriebenes Programm immer auf dem aktuellsten Stand halten.
Desshalb möchte ich per update Button aus einer besteheden Exel Datei alle vorhandenen Tabellen in meine Access Datenbank übertragen da es über 120000 Datensätze sind, enthält die Exel Datei mehrere Tabellen Blätter

Ein connect zur Access DB besteht schon.

Hab ein wenig Googled und den u.g. Code gefunden.
Wenn ich mit dieser Funktion meine Exel Datei öffne, müßte ich nur noch wissen wie ich die Daten in meine DB bekomme:

Function ZellInhalt(XlsDatei as str, Zelle as string) as string
Dim XL As Excel.Application
Dim XLWorkBook As Excel.Workbook
Dim XLWorkSheet As Excel.Worksheet
Dim z As Integer
Dim wbk As String

' Excel öffnen
On Error Resume Next
Set XL = GetObject(, "Excel.Application")
If Err.Number Then
Err.Clear
Set XL = CreateObject("Excel.Application")
If Err.Number Then
MsgBox "Excel kann nicht geöffnet werden", vbExclamation, "Excel-Fehler"
End
End If
End If
On Error GoTo 0

' Excel-Datei öffnen
Set XLWorkBook = XL.Workbooks.Open(XlsDatei)
Set XLWorkSheet = XLWorkBook.ActiveSheet

' Inhalt der gewünschten Zelle ermitteln
ZellInhalt = XLWorkSheet.Range(Zelle).Value

' Excel schließen
XLWorkBook.Close False
Set XLWorkSheet = Nothing
Set XLWorkBook = Nothing
Set XL = Nothing

End Function

Da ich noch relativ frisch bin, hoffe ich das ihr mir helfen könnt.

Gruß,
Andreas

 

[whisky1108]

Habe nun diesen Code verwendet klicken
die zu übertragenen Tabellen gebe ich per inputbox vor.
Nur wie stosse ich das Access -Modul über VB an?

 

[whisky1108]

Hallo zusammen,
Hier nun mein code, da ich noch nicht der VB profi bin und mir vieles zusammengeschustert habe verbessert mich bitte wenn code überflüssig ist.

Also das Problem das ich habe ist, das die Datenquelle sich ständig ändert. (d.h.Exeldatei name und die Tabellenblätter)

Um immer den richtigen Dateinamen zu haben lese ich ihn aus:

Private Sub findMyFiles(myPath As String, myFileSpec As String _
 Dim myFolder, myFolderLoop, FSO
Dim myFilNam As String
On Error GoTo fehlerende
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myFolder = FSO.GetFolder(myPath)
    myFilNam = Dir$(FSO.BuildPath(myFolder.Path, myFileSpec), _
    vbNormal Or vbHidden Or vbSystem Or vbReadOnly)

Text1.Text = myFilNam
fehlerende:
End Sub

Und dann die Tabellenblätter (momentan sind es max. 5)

Fage: Wenn ich die tbl.namen keinen festen Objekten zuordne (wie bsp. einer Textbox)
wie bekomme ich Sie in die nächste Funktion? Die Dim Werte in die nächste Funktion übergeben t nicht bzw ich weiß momentan nicht wie.

Sub DAO_ListTablesExcel()
Dim myArray(1000) As String, nF As Integer, nD As Integer
Dim dbd1, dbd2, dbd3, dbd4, dbd5, zähler
zähler = 0
nF = -1
nD = 0
Call findMyFiles(App.Path , "*.xls", myArray, nF, nD)

    Dim strDatei_Excel As String
    Dim DB1 As DAO.Database
    Dim tbl As DAO.TableDef
    strDatei_Excel = App.Path & Text1.Text
    Set DB1 = OpenDatabase(strDatei_Excel, False, False, "Excel 8.0;")
    For Each tbl In DB1.TableDefs
       zähler = zähler + 1
    If zähler = 1 Then
    tbl1.Text = tbl.Name
    End If
    If zähler = 2 Then
    tbl2.Text = tbl.Name
    End If
    If zähler = 3 Then
    tbl3.Text = tbl.Name
    End If
    If zähler = 4 Then
    tbl4.Text = tbl.Name
    End If
    If zähler = 5 Then
    tbl5.Text = tbl.Name
    End If
    Next
End Sub

Das ganze über button aktiviert (connect zu ADODB besteht schon):

Private Sub Command4_Click()
Call DAO_ListTablesExcel

    Dim strDatei_Excel As String    'Quelldatei Excel
    Dim strTab_Excel As String      'Tabellenblatt Excel
    Dim strTab_Excel2 As String      'Tabellenblatt Excel
    Dim strTab_Excel3 As String      'Tabellenblatt Excel
    Dim strTab_Excel4 As String      'Tabellenblatt Excel
    Dim strTab_Excel5 As String      'Tabellenblatt Excel
    Dim strDatei_Access As String   'Zieldatei Access
    Dim strTab_Access As String     'Tabellenname Access
    Dim strSQL1 As String           '=Tabellenerstellungsabfrage
    Dim strSQL2 As String           '=Anfügeabfrage
    Dim strSQL3 As String           '=Anfügeabfrage
    Dim strSQL4 As String           '=Anfügeabfrage
    Dim strSQL5 As String           '=Anfügeabfrage
    Dim DB1 As DAO.Database         'Verweis auf Microsoft DAO 3.6 Object Library setzen


    conn.Execute "DELETE * FROM TEST;" ' alte Dateien löschen
    strDatei = Text1.text
    strDatei_Excel = App.Path & Text1.Text


    strTab_Excel = tbl1.Text
    strTab_Excel2 = tbl2.Text
    strTab_Excel3 = tbl3.Text
    strTab_Excel4 = tbl4.Text
    strTab_Excel5 = tbl5.Text
    strDatei_Access = App.Path & "\test.mdb"
    strTab_Access = "TEST"
    Set DB1 = OpenDatabase(strDatei_Excel, False, False, "Excel 8.0;")
    
 
    strSQL1 = "INSERT INTO " & strTab_Access & " IN '" & strDatei_Access & "' " & _
              "SELECT * " & _
              "FROM [" & strTab_Excel & "];"
   

    strSQL2 = "INSERT INTO " & strTab_Access & " IN '" & strDatei_Access & "' " & _
              "SELECT * " & _
              "FROM [" & strTab_Excel2 & "];"
   

    strSQL3 = "INSERT INTO " & strTab_Access & " IN '" & strDatei_Access & "' " & _
              "SELECT * " & _
              "FROM [" & strTab_Excel3 & "];"

  
    strSQL4 = "INSERT INTO " & strTab_Access & " IN '" & strDatei_Access & "' " & _
              "SELECT * " & _
              "FROM [" & strTab_Excel4 & "];"
  
 
    strSQL5 = "INSERT INTO " & strTab_Access & " IN '" & strDatei_Access & "' " & _
              "SELECT * " & _
              "FROM [" & strTab_Excel5 & "];"
 
    If tbl1.Text <> "" Then
    DB1.Execute strSQL1
    End If
    If tbl2.Text <> "" Then
    DB1.Execute strSQL2
    End If
    If tbl3.Text <> "" Then
    DB1.Execute strSQL3
    End If
    If tbl4.Text <> "" Then
    DB1.Execute strSQL4
    End If
    If tbl5.Text <> "" Then
    DB1.Execute strSQL5
    End If

    DB1.Close

    Set DB1 = Nothing
    MsgBox "Update erfolgreich", vbOKOnly, "Update:"
    End If

    End Sub

Falls noch etwas verbesserungswürdig ist dann lasst es mich wissen .

Gruss,
Andreas