Fortschrittsbalken mit Prozentanzeige für Excel-Makro

[mdt8ws]

Hallo zusammen,

ich habe versucht für das nachfolgende Makro einen Fortschrittsbalken mit Prozentanzeige zu erstellen.
Komme da aber nicht weiter und bitte um eure Unterstützung, da ich mich nicht besonders gut mit VBA auskenne.
Auf verschiedenen Internetseiten habe ich gelesen, dass zunächst eine Userform erstellt werden muss, die dann
dem Makro mit einem weiteren Code zugewiesen wird. Leider bin ich an dieser Stelle echt überfordert.

Ich würde mich sehr über Hilfe freuen.

Viele Grüße
Gerhard

Code:

Sub Report_Aktualisierung()
'
' Report_Aktualisierung Makro
'
Dim Antwort As VbMsgBoxResult
Antwort = MsgBox("Soll die Aktualisierung ausgeführt werden? Bearbeitungszeit ca. 30 Sekunden", vbYesNo, "Aktualisierung-Reports")

If Antwort = vbYes Then

Application.ScreenUpdating = False
Application.DisplayAlerts = False
    Application.Run "Mitgliederdatei.xlsm!Report_alle_Schützen"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_interne_Schützen"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_externe_Schützen"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_Ehrenmitglieder"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_Schützen"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_Jungschützen"
    ActiveWindow.Close
    Application.Run "Mitgliederdatei.xlsm!Report_Mitgliederstand"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_Veränderungen"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_Veränderungen_Statistik"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_alle_Regenten"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_mehrfach_Regenten"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_Vereinsjubiläum"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_Jubelmajestäten"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_Geburtstage"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_Ü60_Treffen"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Application.Run "Mitgliederdatei.xlsm!Report_Einwilligungserklärung"
    ActiveWindow.Close
    Sheets("Report-Serienbriefe").Select
    Range("C34").Select
    Application.DisplayAlerts = True
    End If

[RPP63]

Moin!
Bevor ich die Frage beantworte, solltest Du vorher folgendes erläutern:
In welcher Datei steht Report_Aktualisierung()?

Stelle mal den Code von "Mitgliederdatei.xlsm!Report_alle_Schützen" hier rein!
Beziehen sich alle Deine Calls auf Mitgliederdatei.xlsm?

Ich ahne, dass Du 16-mal dieselbe Datei öffnest und schließt, was wohl 29 der 30 Sekunden ausmacht.

Gruß Ralf

[Fennek]

Hallo,

als erstet sollte einige Angaben ergänzt und der Code bereinigt werden:

- Aus welcher Datei wird der Code gestartet
"App.Run" kann auch aus anderen Dateien Makros starten
- "ActiveWindowClose" ist SEHR unübersichtlich

Sind 10 Sekunden Laufzeit wirklich ein Grund für eine Fortschrittsanzeige?
(bei 1 Stunde würde ich zustimmen)

mfg

[volti]

Hallo Gerhard,

falls es sich nach Optimierung Deines Codes für die dann verbleibende Bearbeitungszeit noch lohnt (Deine Entscheidung) eine Fortschrittsanzeige einzusetzen, hier mal eine Idee dazu.

Ggf. kommt die Sub "Beispiel_Fuer_Prozente" als Ansatz infrage.


  Laufbalken.xlsb (Größe: 41,08 KB / Downloads: 12)

viele Grüße
Karl-Heinz

[mdt8ws]

Hallo zusammen,

Vielen Dank erstmal für die Rückmeldungen. Nachfolgend habe ich den Code für "Mitgliederdatei.xlsm!Report_alle_Schützen" (eins von den 16 Makros) beigefügt.
Die Makros wurden alle durch Aufzeichnung erstellt. Report-Aktualisierung ist ein Tabellenblatt der Mitgliederdatei.
Die einzelnen Reports (insgesamt 16) können auch einzeln erzeugt werden (siehe Schaltflächenübersicht aus dem Tabellenblatt Report-Serienbriefe im Anhang).
Das funktioniert alles sehr gut, nur habe ich mir gedacht, dass für die Anwender in unserem Verein eventuell eine Fortschrittsanzeige sinnvoll ist wenn die Aktualisierung aller 16
Reports gestartet wird. Ich hoffe, dass ich mir so halbwegs verständlich ausgedrückt habe.

VG Gerhard

Code:

Sub Report_alle_Schützen()
'
' Report_alle_Schützen Makro
'

'
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Sheets("Mitglieder").Select
    Application.Run "Mitgliederdatei.xlsm!Kopieren_Mitglieder"
    Selection.AutoFilter
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("G:I").Select
    Selection.Delete Shift:=xlToLeft
    Columns("I:K").Select
    Selection.Delete Shift:=xlToLeft
    Columns("W:X").Select
    Selection.Delete Shift:=xlToLeft
    Rows("1:1").Select
    Selection.RowHeight = 41.25
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("C3").Select
    With ActiveWindow
        .SplitColumn = 2
        .SplitRow = 2
    End With
    ActiveWindow.SplitRow = 1
    ActiveWindow.FreezePanes = True
    ActiveWindow.SmallScroll Down:=-36
    Cells.Select
    Selection.FormatConditions.Add Type:=xlExpression, Formula1:= _
        "=REST(ZEILE();2)=0"
    Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
    With Selection.FormatConditions(1).Interior
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark2
        .TintAndShade = 0
    End With
    Selection.FormatConditions(1).StopIfTrue = False
    Range("D8").Select
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = ""
        .PrintTitleColumns = ""
    End With
      Application.CutCopyMode = False
    With ActiveSheet.PageSetup
        .PrintTitleRows = "$1:$1"
        .PrintTitleColumns = ""
    End With
    Application.PrintCommunication = True
    ActiveSheet.PageSetup.PrintArea = ""
    Application.PrintCommunication = False
    With ActiveSheet.PageSetup
        .LeftHeader = ""
        .CenterHeader = "Report-alle-Schützen"
        .RightHeader = ""
        .LeftFooter = ""
        .CenterFooter = ""
        .RightFooter = ""
        .LeftMargin = Application.InchesToPoints(0.511811023622047)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0.511811023622047)
        .BottomMargin = Application.InchesToPoints(0.511811023622047)
        .HeaderMargin = Application.InchesToPoints(0.31496062992126)
        .FooterMargin = Application.InchesToPoints(0.31496062992126)
        .PrintHeadings = False
        .PrintGridlines = False
        .PrintComments = xlPrintNoComments
        .CenterHorizontally = False
        .CenterVertically = False
        .Orientation = xlLandscape
        .Draft = False
        .PaperSize = xlPaperA4
        .FirstPageNumber = xlAutomatic
        .Order = xlDownThenOver
        .BlackAndWhite = False
        .Zoom = 53
        .PrintErrors = xlPrintErrorsDisplayed
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .ScaleWithDocHeaderFooter = True
        .AlignMarginsHeaderFooter = True
        .EvenPage.LeftHeader.Text = ""
        .EvenPage.CenterHeader.Text = ""
        .EvenPage.RightHeader.Text = ""
        .EvenPage.LeftFooter.Text = ""
        .EvenPage.CenterFooter.Text = ""
        .EvenPage.RightFooter.Text = ""
        .FirstPage.LeftHeader.Text = ""
        .FirstPage.CenterHeader.Text = ""
        .FirstPage.RightHeader.Text = ""
        .FirstPage.LeftFooter.Text = ""
        .FirstPage.CenterFooter.Text = ""
        .FirstPage.RightFooter.Text = ""
    End With
    Application.PrintCommunication = True
    Sheets("Tabelle1").Select
    Sheets("Tabelle1").Name = "Report-alle-Schützen"
    Range("A2").Select
    ChDir "C:\Telekom\MagentaCLOUD\Dokumente\Reports"
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Filename:= _
        "C:\Telekom\MagentaCLOUD\Dokumente\Reports\Alle-Schützen-rpt.xlsx", FileFormat _
        :=xlOpenXMLWorkbook, CreateBackup:=False
        Application.DisplayAlerts = True
End Sub

[Klaus-Dieter]

Hallo,

zwei Anmerkungen:

- aufgezeichnete Makros haben ein erhebliches Optimierungspotenziel. (Könnte sich auch auf die Laufzeit auswirken).
- Fortschrittanzeigen bremsen die Laufzeit noch weiter aus. Insofern sollte man darauf verzichten und lieber den Quelltext optimieren.

[schauan]

Hallöchen,

zuweilen reicht als Alternative auch die Ausgabe einer Meldung, das noch ein Makro läuft.

Das könnte man als Userform oder Textbox umsetzen. Du könntest dort z.B. als erweiterte Variante eine Liste der Aufgaben anzeigen mit dem jeweiligen Abarbeitungsstatus. Oder Du nutzt dazu die Scripting-PopUps, die kannst Du zwischendurch immer mal kurz oder lang aufpoppen lassen.

Ansonsten, wie schon andere schrieben, macht das für eine kurze Dauer eher keinen Sinn. Da würde ich lediglich am Ende des Makros eine Fertigmeldung ausgeben.

[mdt8ws]

Hallo zusammen,
ich habe nun versucht, die Meldungen während und nach der Bearbeitung des Makros "Report-Aktualisierung" (siehe Anhang) mit 2 UserForms (siehe Anhang) umzusetzen.
Nachfolgend der Ablauf (siehe Anhänge) beim Schließen der Mitgliederdatei und meinem noch bestehenden Problem:
1. Die Mitgliederdatei wird geschlossen
2. Frage: Soll die Aktualisierung ausgeführt werden ? Laufzeit ca. 30 Sekunden ! Ja oder Nein (siehe Anhang Aktualisierung_1)
Bei Bestätigung mit Nein erscheint die Frage: Sollen die Änderungen an Mitgliederdatei.xlms gespeichert werden ?
Das ist auch so ok.
3. Bei Bestätigung mit Ja wird die UserForm1 "Bitte warten ! Aktualisierung läuft ! (siehe Anhang Aktualisierung_2) gestartet bis das Makro abgearbeitet ist.
4. Danach wird die UserForm2 "Aktualisierung beendet !" (siehe Anhang Aktualisierung_3) gestartet. Diese Meldung soll dann mit Bestätigung OK geschlossen werden.
Und hier ist mein Problem, weil auch direkt die Frage nach dem Speichern ernscheint.
Die "Speicherfrage" sollte erst nach dem Bestätigung mit OK erscheinen.
Ich habe diesbezüglich schon einiges ausprobiert, komme aber leider nicht weiter.
Im Anhang habe ich auch noch den Code "UserForm2" und "Diese Arbeitsmappe" beigefügt.
Für euere Unterstützung wäre ich sehr dankbar, denn mit dieser Problemlösung wäre alles aus meiner Sicht perfekt.

Viele Grüße
Gerhard

[schauan]

Hallöchen,

in Deinem Code sehe ich die Ausgabe der Meldung nicht. Eventuell solltest Du UserForm2 nicht vbModeLess aufrufen.

[mdt8ws]

Hallo André,

Aufruf der UserForm2 ohne vbModeLess funktioniert perfekt.
Genauso sollte es sein.
Vielen, vielen DANK !!!

Viele Grüße
Gerhard