Fehlerbehandlung
18.01.2018 22:31:07
Ralf
nach vergeblicher Suche und einigen erfolglosen Versuchen hoffe ich auf Hilfe in diesem Forum. Ich möchte eine Fehlerbehandlung in den Code einbauen. Der Code funktioniert soweit und ich bin zufrieden. Jedoch können 2 Fehler auftreten welche immer dazu führen das Excel nicht mehr reagiert oder in einer Schleife landet.
Fehlerbehandlung für Fall 1: Die Quell-Datei existiert nicht.
Ist Verhalten: Excel öffnet das Fenster um die Datei manuell zu suchen
Aktion "Abbrechen" führt immer wieder zum öffnen des Datei-Suchen Fensters.
Folge: Excel muss beendet werden.
Soll Verhalten: MsgBox & Exit Sub.
Fehlerbehandlung für Fall 2: Die Quell-Datei ist durch mich geöffnet.
Ist Verhalten: Excel reagiert nicht mehr und es erscheint keine Meldung.
Folge Excel muss beendet werden.
Soll Verhalten: MsgBox & Exit Sub.
Anmerkungen: Wenn eine Datei durch anderen Benutzer geöffnet ist funktioniert der Code.
Private
Sub CommandButton2_Click()
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Jetzt aktualisieren? Die Dauer beträgt ca. 1-2 Minuten." & vbCrLf & "Nach Abschluss der _
Aktualisierung erfolgt eine Meldung." ' Define message.
Style = vbYesNo + vbQuestion + vbDefaultButton2 ' Define buttons.
Title = "Datenaktualisierung!" ' Define title.
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then ' User chose Yes.
MyString = "Yes" ' Perform some action.
Else ' User chose No.
Exit Sub 'MyString = "No" ' Perform some action.
End If
Dim R As Range
Dim ZTabelle As String, ZZelle As String
Dim QPfad As String, QDatei As String, QTabelle As String, QZelle As String
Dim Maske As String, Temp As String
'Syntax für einen Zellverweis mit Pfad auf eine externe Datei
Maske = "'@Pfad[@Datei]@Tabelle'!@Zelle"
With Sheets("Referenz")
On Error Resume Next
'Durchlaufe alle Zellen von A2 bis A?
For Each R In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
'Werte aus dieser Zeile einlesen (einfacher zu debuggen)
ZTabelle = .Range("A" & R.Row)
ZZelle = .Range("B" & R.Row)
QPfad = .Range("C" & R.Row)
QDatei = .Range("D" & R.Row)
QTabelle = .Range("E" & R.Row)
QZelle = .Range("F" & R.Row)
'Der Pfad muss einen \ am Ende haben
If Right(QPfad, 1) "\" Then QPfad = QPfad & "\"
'Syntax-String holen und die Felder ersetzen
Temp = Maske
Temp = Replace(Temp, "@Pfad", QPfad)
Temp = Replace(Temp, "@Datei", QDatei)
Temp = Replace(Temp, "@Tabelle", QTabelle)
Temp = Replace(Temp, "@Zelle", QZelle)
'Wert einlesen
Sheets(ZTabelle).Range(ZZelle) = DDE(Temp)
Next
End With
Function DDE(ByVal Reference As String) As Variant
Static XL As Application
On Error Resume Next
'Issue: When called as UDF and Reference is a cell, Excel supress the 1st ' if any
If InStr(Reference, "'!") > 0 And Left$(Reference, 1) "'" Then Reference = "'" & _
Reference
If XL Is Nothing Then Set XL = CreateObject("Excel.Application")
DDE = XL.ExecuteExcel4Macro(Application.ConvertFormula(Reference, xlA1, xlR1C1, True))
End Function