Hallo,
Ich habe eine Access DB geöffnet. Nun möchte ich eine Tabelle in ein neues Excel Workbook exportieren. Gibt es hierzu einen Thread?
Vielen Dank!
Grüsse Lars
AW: Export Access Tabelle in ein neues Excel Workb
21.06.2007 18:39:00
Anton
Hallo Lars,
probier's damit: Sub Datenbank_in_Tabelle_lesen() Dim wrkDefault 'As Workspace Dim dbsNew ' As DATABASE Dim prpLoop ' As Property Dim test
strDatenbank = Application.GetOpenFilename("MS-Access Datenbank (*.mdb),*.mdb", , _
"Pfad zur Auslieferungsdatenbank ändern") If InStr(1, LCase(strDatenbank), "fals", vbTextCompare) Then Exit Sub Set test = CreateObject("DAO.DBEngine.36") ' Standardarbeitsbereich bestimmen. Set wrkDefault = test.Workspaces(0) 'msgbox wrkDefault.username On Error Resume Next Set dbsNew = wrkDefault.openDatabase(strDatenbank, 1, 0, ";pwd=") If Err.Number = 3031 Then
dbsNew.Close
Err.Clear
passwort = InputBox("Passwort eingeben") Set dbsNew = wrkDefault.openDatabase(strDatenbank, 1, 0, ";pwd=" & passwort) If Err.Number = 3031 Then
dbsNew.Close
Err.Clear
MsgBox "Falsches Passwort!" Exit Sub End If End If If Err.Number = 3356 Then
MsgBox Err.Description Exit Sub End If
Application.Workbooks.Add Dim neuesBlatt As Worksheet For i = 0 To dbsNew.TableDefs.Count - 1 'MsgBox LCase(dbsNew.TableDefs(i).Name) 'MsgBox InStr(1, LCase(dbsNew.TableDefs(i).Name), "msys", vbTextCompare) If InStr(1, LCase(dbsNew.TableDefs(i).Name), "msys", vbTextCompare) <> 1 Then Set neuesBlatt = ActiveWorkbook.Worksheets.Add With neuesBlatt
k = 1
.Name = dbsNew.TableDefs(i).Name
.Rows(1).Font.Bold = True ' .Cells.NumberFormat = "@" Set tdfNew = dbsNew.TableDefs(i) For j = 0 To tdfNew.Fields.Count - 1
.Cells(k, j + 1).Value = tdfNew.Fields(j).Name
Debug.Print tdfNew.Fields(j).Name Next Set rstDatensaetze = dbsNew.OpenRecordset(tdfNew.Name, 2) Do While Not rstDatensaetze.EOF
k = k + 1 For n = 0 To rstDatensaetze.Fields.Count - 1
.Cells(k, n + 1).Value = rstDatensaetze.Fields(n) Next
rstDatensaetze.MoveNext Loop
rstDatensaetze.Close
.Columns.AutoFit End With End If Next
dbsNew.Close End Sub