MsgBoxen in Makro einbauen
11.08.2019 14:24:19
Jürgen
Ich benutze nachfolgendes Makro um einen markierten Bereich in eine Textdatei
zu exportieren.
Könnte mir bitte jemand von euch das Makro folgendermaßen anpassen:
- Beim Start des Makros soll eine MsgBox aufgehen "Bitte markieren Sie einen Bereich"
Der Bereich soll entweder mit der linken Maustaste markiert oder in ein Feld der
MsgBox eingetragen (z.B. B21:C23) werden können. Wenn der Bereich mit der linken
Maustaste markiert wurde, soll der ausgewählte Bereich ebenfalls in der
Texteingabezeile erscheinen.
- Wurde der Bereich markiert bzw. eingetragen und die MsgBox mit "OK" bestätigt,
soll die MsgBox mit Ok geschlossen werden können.
- Für den Fall dass kein Bereich markiert wurde, soll sich eine MsgBox öffnen mit
dem Hinweis: "Sie haben keinen Bereich markiert! Möchten Sie abbrechen? Bei
Auswahl "Ja" soll das Makro beendet werden. Bei Auswahl "Nein" soll die MsgBox
geschlossen und wieder die MsgBox "Bitte markieren Sie einen Bereich" erscheinen.
- Jetzt soll automatisch eine neue MsgBox geöffnet werden mit dem Hinweis:
"Sie haben den folgenden Bereich ausgewählt: B21:C23"
Diese MsgBox soll mit Ok wieder geschlossen werden können.
- Nun soll eine MsgBox "Speichern unter" automatisch geöffnet werden.
Hier soll zum einen ...
... der Dateipfad im Makro vordefiniert werden können z.B. "D:\Daten"
... und der Dateityp ".txt" vordefiniert werden können.
- Nach dem Speichern soll die gespeicherte Textdatei automatisch geöffnet werden
und das Makro beendet werden.
- Wichtig: An der Ausgabe meines bestehenden Makros darf sich nichts ändern.
Mein bisheriges Makro:
Sub SelInText2()
Dim rngZ As Range
Dim celZ As Range
Dim strE As String
Const strDel As String = " " ' Trennzeichen
strE = ""
For Each rngZ In Selection.Rows
If strE "" Then strE = strE & vbCrLf
For Each celZ In rngZ.Cells
strE = strE & Replace(celZ.Text, ",", ".") & strDel
Next celZ
Next rngZ
kk = FreeFile(1)
Open "D:\Daten\SelInText.txt" For Output As kk ' Ausgabedatei - anpassen
Print #kk, strE
Close kk
End Sub
Gruß Jürgen