Public
Sub
DatenÜbertragen()
On
Error
GoTo
Fehler
Const
c_strProvider
As
String
=
"Microsoft.Jet.OLEDB.4.0;"
Const
c_strDB_Path
As
String
=
"Hier kommt Dein Pfad hin>\Testdatenbank.accdb"
Const
c_strDB_Tbl
As
String
=
"Auswertung"
Const
c_strXL_Sheet
As
String
=
"Zusammenfassung"
Const
c_strXL_AZ
As
String
=
"B10"
Const
c_strUserID
As
String
=
"Admin"
Dim
cn
As
ADODB.Connection
Dim
rs
As
ADODB.Recordset
Dim
strSQL
As
String
Dim
strAZ
As
String
Dim
wks
As
Excel.Worksheet
Dim
blnNeuerDS
As
Boolean
Dim
strMsgBox
As
String
Set
wks = ThisWorkbook.Sheets(c_strXL_Sheet)
strAZ = wks.Range(c_strXL_AZ).Value
If
Len(strAZ) > 0
Then
Set
cn =
New
ADODB.Connection
cn.Provider = c_strProvider
cn.Open c_strDB_Path, c_strUserID
cn.CursorLocation = adUseServer
strSQL =
"Select AktZ,Status,Wahrscheinlichkeit,Punkte"
& _
" From "
& c_strDB_Tbl & _
" Where AktZ = '"
& strAZ &
"'"
Set
rs =
New
ADODB.Recordset
With
rs
.ActiveConnection = cn
.CursorType = adOpenKeyset
.LockType = adLockOptimistic
.Open strSQL, Options:=adCmdText
If
.Supports(adUpdate)
And
.Supports(adAddNew)
Then
If
.BOF
Then
.AddNew
.Fields(
"AktZ"
).Value = strAZ
blnNeuerDS =
True
End
If
.Fields(
"Status"
).Value = wks.Range(
"B7"
).Value
.Fields(
"Wahrscheinlichkeit"
).Value = wks.Range(
"B8"
).Value
.Fields(
"Punkte"
).Value = wks.Range(
"B9"
).Value
.Update
If
blnNeuerDS
Then
strMsgBox =
"Das Aktenzeichen "
& strAZ &
" wurde erfolgreich zur DB hinzugefügt."
Else
strMsgBox =
"Das Aktenzeichen "
& strAZ &
" wurde aktualisiert."
End
If
MsgBox strMsgBox, vbInformation,
"Daten übertragen"
Else
MsgBox
"Ich kann die Daten für das Aktenzeichen '"
& strAZ &
"' nicht übertragen."
& vbCrLf & _
"Kein Datensatz übertragen."
, vbExclamation,
"Datenübertragen"
End
If
.Close
End
With
cn.Close
Else
MsgBox
"Es steht kein Aktenzeichen im Arbeitsblatt '"
& c_strXL_Sheet &
"' in Zelle '"
& c_strXL_AZ &
"'."
, _
vbCritical,
"Datenübertragen"
End
If
Raus:
Set
wks =
Nothing
If
Not
rs
Is
Nothing
Then
If
rs.State = adStateOpen
Then
rs.CancelUpdate
rs.Close
End
If
End
If
Set
rs =
Nothing
If
Not
cn
Is
Nothing
Then
If
cn.State = adStateOpen
Then
cn.Close
End
If
Set
cn =
Nothing
Exit
Sub
Fehler:
MsgBox
"Fehler: "
&
CStr
(Err.Number) &
" "
& Err.Description, vbCritical,
"DatenÜbertragen"
Resume
Raus
End
Sub