Office: Probleme mit MsgBox "Abbrechen"

Hallo miteinander,

der untenstehende Code läuft an sich, nur bei MsgBox beim Abbrechen
werden die Daten trotzdem teilweise übertragen.

Und wenn ich abbreche sollte der Code nicht weiterlaufen, sondern
den Ablauf beenden.

Danke und Gruss
Wolf

PHP:

         Option Explicit
Sub Commandbutton_Klick()
Call Makro1
Call Makro2
End Sub

Sub Makro1()
'Private Sub CommandButton2_Click()

'End SubSub Abteilung_PCFSpeichern()
Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim strZiel As String, strPfadZiel As String
Dim bolOpen As Boolean
Dim Zeile_Z As Long, Zelle_Letzte As Range
[b][color="RoyalBlue"]If MsgBox("Team Test jetzt Ãœbertragen & speichern?", vbQuestion + vbOKCancel, _
"Jetzt Ãœbertragen & speichern") = vbCancel Then GoTo Fehler
On Error GoTo Fehler[/color][/b]

Set wbQuelle = ActiveWorkbook 'Datei "Laufkarte_zur_Auftragsabwicklung.xlsm"
Set wksQuelle = wbQuelle.Worksheets("Team_Test")

Application.ScreenUpdating = False

strPfadZiel = "G:\PC\Test\Fertigung\_Auswertung"       '### anpassen ##!!!
strPfadZiel = wbQuelle.Path                'wenn beide Dateien im gleichen Verzeichnis
strZiel = "Berechnung_V09.xlsm"
If fncCheckWorkbookOpen(strZiel) Then
Set wbZiel = Application.Workbooks(strZiel)
bolOpen = True
Else
Set wbZiel = Application.Workbooks.Open(strPfadZiel & Application.PathSeparator _
& strZiel)
bolOpen = False
End If
Set wksZiel = wbZiel.Worksheets("Abteilung_PCF")
With wksZiel


'nächste Einfüge-Zeile ermitteln
Set Zelle_Letzte = .Cells.Find(what:="*", After:=Range("B4"), _
LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If Zelle_Letzte Is Nothing Then
Zeile_Z = 1
Else
Zeile_Z = Zelle_Letzte.Row
End If
'Zellinhalte Ã¼bertragen - nur Werte

wksQuelle.Range("B3:B4:B5:B6:B7:B8:B9:B10:B11:B12:B13:B14:B16:B17:B18").Copy
.Range("B3:B4:B5:B6:B7:B8:B9:B10:B11:B12:B13:B14:B16:B17:B18").PasteSpecial xlPasteValues
wksQuelle.Range("H7").Copy
.Range("L34").PasteSpecial xlPasteValues
wksQuelle.Range("H8").Copy
.Range("L35").PasteSpecial xlPasteValues
wksQuelle.Range("B1").Copy
.Range("B1").PasteSpecial xlPasteValues

End With
Application.CutCopyMode = False
If bolOpen = False Then
wbZiel.Close savechanges:=True
End If
Fehler:
Application.ScreenUpdating = True
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Set wbZiel = Nothing: Set wksZiel = Nothing: Set Zelle_Letzte = Nothing
Set wbQuelle = Nothing: Set wksQuelle = Nothing
End Sub


:)

 

Hi,

Makro 2 läuft natürlich weiter...
Warum lässt du nicht die Sub im Code starten oder steuerst die Subs mit Parametern?

 

Hallo Chris,

weil ich leider nicht viel Ahnung von der ganzen Sache habe. *rolleyes.gif*

Daher weiss ich auch nicht genau, was dein Vorschlag ist.

Kannst du mir ein wenig weiterhelfen ?

Danke und Gruss
Wolf

 

Moin,

der MsgBox ist erstmal völlig schnuppe, ob sie mit Enter oder mit Escape quittiert wird. Erst wenn Buttons angegeben werden (oder wird, kann auch einer sein), reagiert die MsgBox. Schau mal die Hilfe dazu an.

Wenn die Ausführung von Makro2 (kein doller Name, btw) verhindert werden soll, dann mach aus Makro1 eine Function, die einen Wert zurückliefert. Den fragst Du vor dem Aufruf von Makro2 ab.

(Es gibt noch andere Wege ...)

Gruß
Ralf

 

Wie könnte so ein Weg ausschauen ?

 

Hallo Wolf,

Aus meiner Sicht haben die Kollegen schon ganz konkrete Hinweise gegeben.

Nachstehend eine mögliche Umsetzung.
Code:

 

Hallo Aloys,

danke mal für den Code Vorschlag, hab mal versucht, diesen in meinen einzubauen. Leider funktioniert dieser Einbau leider nicht so wie er soll. Was
hab ich da wieder falsch gemacht ?*frown.gif*

Danke und Gruss
Wolf

PHP:

         Option Explicit

Dim swCancel As Boolean         'True = Code abbrechen

Sub Commandbutton_Klick()
Call Makro1
If swCancel = True Then Exit Sub

Call Makro2
End Sub


Sub Makro1()




Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim strZiel As String, strPfadZiel As String
Dim bolOpen As Boolean
Dim Zeile_Z As Long, Zelle_Letzte As Range
'    Dim swCancel As Boolean

If MsgBox("Team Wolf jetzt Ãœbertragen & speichern?", vbQuestion + vbOKCancel, _
"Jetzt Ãœbertragen & speichern & löschen Werte Team Wolf") = swCancel Then



Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
swCancel = True
End Select
End With

Set wbQuelle = ActiveWorkbook 'Datei "Laufkarte_zur_Auftragsabwicklung.xlsm"
Set wksQuelle = wbQuelle.Worksheets("Team_Wolf")

Application.ScreenUpdating = False

strPfadZiel = "C:\Users\Monika\Desktop\Archiv Wolfram\RCV_NEU"       '### anpassen ##!!!
strPfadZiel = wbQuelle.Path                'wenn beide Dateien im gleichen Verzeichnis
strZiel = "Berechnung Abteilung PAF_V08.xlsm"
If fncCheckWorkbookOpen(strZiel) Then
Set wbZiel = Application.Workbooks(strZiel)
bolOpen = True
Else
Set wbZiel = Application.Workbooks.Open(strPfadZiel & Application.PathSeparator _
& strZiel)
bolOpen = False
End If
Set wksZiel = wbZiel.Worksheets("Abteilung_PAF")
With wksZiel


'nächste Einfüge-Zeile ermitteln
Set Zelle_Letzte = .Cells.Find(what:="*", After:=Range("B4"), _
LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If Zelle_Letzte Is Nothing Then
Zeile_Z = 1
Else
Zeile_Z = Zelle_Letzte.Row
End If
'Zellinhalte Ã¼bertragen - nur Werte

wksQuelle.Range("B3:B4:B5:B6:B7:B8:B9:B10:B11:B12:B13:B14:B16:B17:B18").Copy
.Range("B3:B4:B5:B6:B7:B8:B9:B10:B11:B12:B13:B14:B16:B17:B18").PasteSpecial xlPasteValues
wksQuelle.Range("H7").Copy
.Range("L34").PasteSpecial xlPasteValues
wksQuelle.Range("H8").Copy
.Range("L35").PasteSpecial xlPasteValues

End With
Application.CutCopyMode = False
If bolOpen = False Then
wbZiel.Close savechanges:=True
End If
Fehler1:
Application.ScreenUpdating = True
With Err
Select Case .Number
Case 0 Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Set wbZiel = Nothing: Set wksZiel = Nothing: Set Zelle_Letzte = Nothing
Set wbQuelle = Nothing: Set wksQuelle = Nothing
End If

End Sub


 

Hallo Aloys,

danke mal für den Code Vorschlag, hab mal versucht, diesen in meinen einzubauen. Leider funktioniert dieser Einbau leider nicht so wie er soll. Was
hab ich da wieder falsch gemacht ?*frown.gif*

Danke und Gruss
Wolf

Option Explicit

Dim swCancel As Boolean 'True = Code abbrechen

Sub Commandbutton_Klick()
Call Makro1
If swCancel = True Then Exit Sub

Call Makro2
End Sub


Sub Makro1()




Dim wbQuelle As Workbook, wksQuelle As Worksheet
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim strZiel As String, strPfadZiel As String
Dim bolOpen As Boolean
Dim Zeile_Z As Long, Zelle_Letzte As Range
' Dim swCancel As Boolean

If MsgBox("Team Wolf jetzt Ãœbertragen & speichern?", vbQuestion + vbOKCancel, _
"Jetzt Übertragen & speichern & löschen Werte Team Wolf") = swCancel Then



Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
swCancel = True
End Select
End With

Set wbQuelle = ActiveWorkbook 'Datei "Laufkarte_zur_Auftragsabwicklung.xlsm"
Set wksQuelle = wbQuelle.Worksheets("Team_Wolf")

Application.ScreenUpdating = False

strPfadZiel = "C:\Users\Monika\Desktop\Archiv Wolfram\RCV_NEU" '### anpassen ##!!!
strPfadZiel = wbQuelle.Path 'wenn beide Dateien im gleichen Verzeichnis
strZiel = "Berechnung Abteilung PAF_V08.xlsm"
If fncCheckWorkbookOpen(strZiel) Then
Set wbZiel = Application.Workbooks(strZiel)
bolOpen = True
Else
Set wbZiel = Application.Workbooks.Open(strPfadZiel & Application.PathSeparator _
& strZiel)
bolOpen = False
End If
Set wksZiel = wbZiel.Worksheets("Abteilung_PAF")
With wksZiel


'nächste Einfüge-Zeile ermitteln
Set Zelle_Letzte = .Cells.Find(what:="*", After:=Range("B4"), _
LookIn:=xlFormulas, lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlPrevious)
If Zelle_Letzte Is Nothing Then
Zeile_Z = 1
Else
Zeile_Z = Zelle_Letzte.Row
End If
'Zellinhalte übertragen - nur Werte

wksQuelle.Range("B3:B4:B5:B6:B7:B8:B9:B10:B11:B12:B13:B14:B16:B17:B18").Copy
.Range("B3:B4:B5:B6:B7:B8:B9:B10:B11:B12:B13:B14:B16:B17:B18").PasteSpecial xlPasteValues
wksQuelle.Range("H7").Copy
.Range("L34").PasteSpecial xlPasteValues
wksQuelle.Range("H8").Copy
.Range("L35").PasteSpecial xlPasteValues

End With
Application.CutCopyMode = False
If bolOpen = False Then
wbZiel.Close savechanges:=True
End If
Fehler1:
Application.ScreenUpdating = True
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Set wbZiel = Nothing: Set wksZiel = Nothing: Set Zelle_Letzte = Nothing
Set wbQuelle = Nothing: Set wksQuelle = Nothing
End If

End Sub

 

Hallo Wolf,

Klar - jetzt taucht plötzlich eine neue MsgBox-Anweisung auf.
Mein Vorschlag: Zurück auf Los !

Du hast eine Prozedur, in der nacheinander Macro 1 und 2 aufgerufen werden.
Jetzt erläutere mal, was Du wann erreichen willst.
Dann kann man Dir ggf einen passenden Code-Vorschlag liefern.

Gruß
Aloys

 

Moin,

Code:

diese Anweisung ist sinnlos, bevor swCancel gesetzt wurde.

Beantworte Dir mal auf einem Zettel ein paar Fragen:

• Soll Makro1 immer ausgeführt werden?

• Wenn ja - was soll passieren?

• Wenn nein - was soll passieren?

Noch 'ne Anmerkung: Die Code-Darstellung ist unter aller Sau - keine Einrückungen, sinnlose Unterstreichungen, obskure Rahmen um jede Zeile. Verwende bitte die Code-Brackets, wer will denn vom Lesen Augenkrebs kriegen.

 

Hallo Miteinander,

So dann werde ich mein Projekt nochmal vom Anfang an erläutern versuchen.

1. Werte werden in die Tabelle(PP__1) eingetragen und berechnet.

2. Die berechneten Werte werden in die Tabelle(Team-Test) übergeben mit
Formel.
3. Die Werte aus der Tabelle (Team-Test) werden in eine geschlossene Datei übertragen und die einzel Werte aus PP__1 werden in die Tabellenblätter Test_1 usw. übertragen mittels button.

Aber es sollen nur die Werte übertragen werden von PP__1 in die Tabellen Test_1 usw. wenn in der Spalte D D6*biggrin.gif*15 ein Wert vorhanden ist, weil es soll keine O Werte in die Tabellen übertragen.

4. Und die MSg - Box mit dem Abbrechen dient nur dazu, fals jemand noch drauf kommt wenn er übertragen gedrückt hat, dass er was vergessen hat und nochmal was in der Tabelle (PP__1) neu eintragen möchte. Und so sollte beim Abbrechen der Code von neuem beginnen.

Habe auch meine Original Datei beigefügt, wo man sicher besser erkennen kann was ich möchte, was das mit dem erklären ist so eine Sache. *wink.gif*

So nun hoffe ich mal, dass ihr mit meinen Ausführungen was anfangen könnt.

Danke und Gruss
Wolf

 

Hi,

Set wbQuelle = Nothing: Set wksQuelle = Nothing
Exit Sub

füge im Makro1
vor End Sub
ein Exit Sub ein

dann wird Makro 2 bei einem Fehler nicht ausgeführt.

 

meine Angaben sind wohl mal wieder schlecht ?

Bitte Unklarheiten mitteilen, dann versuche ich sie zu beantworten.

Danke und Gruss
Wolf

 

Hi,

? Bricht der Code den nicht ab?
Exit Sub vermeide ich zumeist, da ich glaubte du hast eine Userform. (sonst würde diese geschlossen)
Aber der Code liegt ja nur auf einer Schaltfläche auf dem Tabellenblatt, deshalb würde Exit SUB alles abbrechen.

Den Rest habe ich jetzt nicht angeschaut!

Ist das nicht mehr die aktuelle Frage?

 

nun das mit dem Exit Sub hab ich probiert und das funktioniert leider nicht.

Und ob es noch um die Frage geht, also Aloys hat ja gemeint, dass er das ganze nochmal neu anfangen würde.

Und so habe ich meine Original Datei angehängt und noch dazu geschrieben was ich damit machen möchte.

Daher habe ich jetzt mal gefragt, was nicht so ganz klar ist.

Gruss
Wolf