Access anbindung an Excel
04.05.2006 13:07:59
erko
ich habe ein Problem mit dieser Funktion.
Das habe ich in Access-VBA geschrieben und möchte das gerne in Excel-VBA übertragen.
Was muss ich dabei anpassen und wie?
Ich weis das die Verbindung zu Access fehl, wie bekomme ich das hin?
Erko
Public
Sub ExcelRecordsetClick()
Dim oExcel As Excel.Application, db As Dao.Database, rs As Dao.Recordset, i As Long
On Error Resume Next
Err.Clear
Set oExcel = GetObject(, "Excel.Application ")
If Err.Number <> 0 Then Set oExcel = CreateObject("Excel.Application")
On Error GoTo 0
oExcel.Visible = True
oExcel.Workbooks.Add
oExcel.ActiveSheet.Name = CStr(Me!Blatt)
Set db = CurrentDb
Set rs = db.OpenRecordset("qryAdresse", dbOpenSnapshot)
If Me!Spaltenk Then
For i = 0 To rs.Fields.Count - 1
oExcel.Cells(1, i + 1) = rs.Fields(i).Name
Next i
oExcel.Range("A2").Select
Else
oExcel.Range("A1").Select
End If
Dim xlApp As Excel.Application
Dim xlWorkbook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim xlRange As Excel.Range
Dim rstExport As Dao.Recordset
Dim ia, ib
Set db = CurrentDb
Set rstExport = db.OpenRecordset("qryAdresse", dbOpenSnapshot)
Do While Not rs.EOF
ia = ia + 1
For i = 0 To rs.Fields.Count - 1
oExcel.Cells(ia + 1, i + 1) = CStr(Nz(rs.Fields(i).Value, ""))
Next i
rs.MoveNext
Loop
oExcel.Range("A4") = "Test"
oExcel.Visible = True
Set oExcel = Nothing
Set rs = Nothing
Set db = Nothing
End Sub
Und das versuche ich mit Excel-VBA zu realisieren und bekomme es nicht hin:
Sub Access_Import1()
Dim ADOC As ADODB.Connection
Dim DBS As ADODB.Recordset
Dim AnzZeile As Integer
Dim i As Integer
Dim Nr As String
Dim SuchAbfrage As String
Dim PfadAccess As String
Dim TabNa As String
PfadAccess = "D:\07_GPS\01_Datenbank\Management Consulting.mdb"
TabNa = "Tabelle1"
On Error GoTo Fehlerbehandlung
Sheets(TabNa).Activate
Range("A1").Select
AnzZeile = Sheets(TabNa).Cells(Rows.Count, 1).End(xlUp).Row
Set ADOC = New ADODB.Connection
With ADOC
.Provider = "Microsoft.jet.oledb.4.0"
.Open "D:\07_GPS\01_Datenbank\Management Consulting.mdb" 'PfadAccess
End With
i = 2
Do While i <= 10 'AnzZeile
i = i + 1
Nr = CStr(Sheets(TabNa).Cells(i, 1).Value)
Nr = Format(Nr, "000000000000")
SuchAbfrage = "SELECT * FROM [STK] WHERE MatNr = '" & Nr & "'"
Set DBS = New ADODB.Recordset
With DBS
.Open Source:=SuchAbfrage, ActiveConnection:=ADOC, CursorType:=adOpenKeyset, LockType:=adLockOptimistic
End With
Sheets(TabNa).Activate
Range("B3").Select
'While Not DBS.EOF
'Set db = CurrentDb
'Set rstExport = db.OpenRecordset("qryAdresse", dbOpenSnapshot)
Dim ia, ib
Dim oExcel As Excel.Application
Do While Not DBS.EOF
ia = ia + 1
For i = 0 To DBS.Fields.Count - 1
oExcel.Cells(ia + 1, i + 1) = CStr(DBS.Fields(i).Value)
Next i
DBS.MoveNext
Loop
' Columns("A:G").AutoFit
DBS.Close
Set DBS = Nothing
Loop
ADOC.Close
Set ADOC = Nothing
Exit Sub
Fehlerbehandlung:
MsgBox "Es ist ein Fehler aufgetreten!" & Err.Description
End Sub