AW: Excel Access DB Excel
02.03.2011 18:53:59
Thomas
Hallo zusammen,
Erst einmal Danke an Alle
Ich kenne das Forum seit 3 Tage, hab schon einiges rausgeholt!
besonderer Dank an Martin S., Ramses + Case
von wem kam der Tip ?
Ich habs schon halber geschaft und zwar so !
Option Explicit
Public Sub DataBase_13()
Dim rcsEntry As New ADODB.Recordset
Dim catCatalog As New ADOX.Catalog
Dim objConn As ADODB.Connection
Dim strSheetName As String
Dim strFileName As String
Dim blnTMP As Boolean
Dim intNumber As Integer
Dim wb0 As Workbook ' geöffnetes Workbook - Lohnerfassung
Dim wb1 As Workbook ' Personal-Workbook
Dim wb2 As Workbook ' Lieferschein-Workbook
Dim wb3 As Workbook ' LieferscheinÜbertrag-Workbook
Dim wb4 As Workbook ' Rechnungs -Workbook
Dim iRow As Integer, iRowL As Integer, iRowT As Integer 'Zaehl- und Hilfsvariablen
Dim Flag1 As Boolean 'Hilfsvariable
Dim i As Integer
Dim WsMA As Worksheet, WsFA As Worksheet 'Ziel- und Quellblatt
Dim WsMAName As String 'Mitarbeitername im Zielblatt
Dim dlgSundHLieferscheine
Dim lblLieferdatum
Dim lblAuftragsdatum
Dim Ws
Dim InputMessage
Dim ibox
Dim mbox
Dim KundenNR
Dim ArtikelNR
Dim AuftragsNR
Dim KommissionFA
Dim LieferscheinNR
Dim LieferBestellNR
Dim RechnungsNR
Dim AuftragsDatum
Dim MengeProKiste
Dim Kunden_WBName
Dim Menge
Dim ID&
Dim b&
Dim n
Dim v
Dim Teiler
Dim Kopieanzahl
Dim Kistenanzahl
Dim Fortsetzung
Dim KistenanzahlRest
Dim k
Dim number As Variant
Dim Zeiten_WBName
Set wb4 = ActiveWorkbook
On Error GoTo Fin
If ACC_Active Then
MsgBox "Please close all ACCESS instances!"
Exit Sub
End If
' strFileName = " D:\Verwaltung\Datenlisten\Artikelpreisliste01.accdb" ' So gehts nicht. _
Warum ?
strFileName = "D:\Verwaltung\Datenlisten\Artikelpreisliste01.mdb"
If Dir(strFileName) = "" Then
MsgBox "Data base does not exist!"
Exit Sub
End If
Set rcsEntry = New ADODB.Recordset
Set objConn = New ADODB.Connection
With objConn
.CursorLocation = adUseClient
.Provider = "Microsoft.Jet.OLEDB.4.0"
.Properties("Data Source") = strFileName
.Open
End With
Set catCatalog.ActiveConnection = objConn
On Error Resume Next
Err.Clear
strSheetName = catCatalog.Tables("ArtikelPreise").Name
blnTMP = (Err = 0)
On Error GoTo 0
If Not blnTMP Then
MsgBox "Table ""ArtikelPreise"" missing!"
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
Exit Sub
Else
With rcsEntry
.ActiveConnection = objConn
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.CursorType = adOpenKeyset
.Source = "SELECT NUMMER, NETTO, SCHLUESSEL, AngebotNr FROM " & "ArtikelPreise" & _
" WHERE ArtikelID=" & Sheet1.Cells(3, 4)
.Open
If .BOF = True Or .EOF = True Then MsgBox "Wrong number!": _
rcsEntry.Close: _
objConn.Close: _
Exit Sub
.MoveFirst
' Sheet1.Cells(3, 5).CopyFromRecordset rcsEntry
NUMMER = .Fields(0).Value
netto = .Fields(1).Value
SCHLUESSEL = .Fields(2).Value
AngebotNr = .Fields(3).Value
Sheet1.Cells(19, 3).Value = .Fields(0).Value
wb4.Sheets("Rechnungen").Cells(2, 7) = .Fields(0).Value
Sheet1.Cells(18, 3).Value = .Fields(1).Value
wb4.Sheets("Rechnungen").Cells(4 + b, 25) = .Fields(1).Value
Sheet1.Cells(23, 3).Value = .Fields(2).Value
wb4.Sheets("Rechnungen").Cells(4 + b, 26) = .Fields(2).Value
Sheet1.Cells(24, 3).Value = .Fields(3).Value
wb4.Sheets("Rechnungen").Cells(2, 8) = .Fields(3).Value
End With
rcsEntry.Close
objConn.Close
Set rcsEntry = Nothing
Set objConn = Nothing
End If
On Error GoTo 0
Exit Sub
Fin:
MsgBox "Error " & Err.number & " (" & Err.Description & ")"
Set rcsEntry = Nothing
Set objConn = Nothing
End Sub
Private Function ACC_Active() As Boolean
Dim ACCApp As Object
On Error Resume Next
Set ACCApp = GetObject(, "Access.Application")
If Err.number = 429 Then
ACC_Active = False
Else
ACC_Active = True
End If
End Function
Die Situation ist jetzt folgende:
In einer Excel-Tabelle werden die Zahlen automatischen verarbeitet, und sollen dann zurück in die Access DB geschickt werden
Über einen entsprechenden Code wäre ich daher sehr dankbar!
Vielen Dank im Voraus!