Option
Explicit
Public
Sub
DatenÜbertragen()
Const
c_strProvider
As
String
=
"Microsoft.ACE.OLEDB.12.0;"
Const
c_strDB_Path
As
String
=
"C:\... \... .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
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 = adUseClient
strSQL =
"Select Status, Wahrscheinlichkeit, Punkte"
& _
" From "
& c_strDB_Tbl & _
" Where AktZ = '"
& strAZ &
"'"
Set
rs =
New
ADODB.Recordset
With
rs
.ActiveConnection = cn
.CursorType = adOpenForwardOnly
.LockType = adLockOptimistic
.Open strSQL, Options:=adCmdText
If
Not
.BOF
Then
If
.Supports(adUpdate)
Then
.Fields(
"Status"
) = wks.Range(
"B7"
).Value
.Fields(
"Wahrscheinlichkeit"
) = wks.Range(
"B8"
).Value
.Fields(
"Punkte"
) = wks.Range(
"B9"
).Value
.Update
Else
MsgBox
"Ich kann die Daten für das Aktenzeichen '"
& strAZ &
"' nicht übertragen."
& vbCrLf & _
"Kein Datensatz übertragen."
, vbExclamation,
"Datenübertragen"
End
If
Else
MsgBox
"Das Aktenzeichen '"
& strAZ &
"' gibt es noch nicht."
& 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.Close
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