Statusleiste Fortschritt Makro
26.01.2007 13:57:09
Michael
Ich habe hier etwas gelesen von einer Statusanzeige bzw. Timerbalken, der den Fortschritt des Makros anzeigt. Ich habe es mal probiert, ich bekomme aber nur eine Msg-Box hin, die die verstrichene Zeit zeigt. Meine Frage ist, ob ein Balken o.ä. bei folgendem Makro funktionieren würde(Über Tastenkombo wird die aktuelle Speisekarte ausgelesen und die relevanten Gerichte in einen Gültigkeitsbereich geworfen, sofern sie noch nicht existieren):
Function IsWorkbookOpen(strWB As String) As Boolean
On Error Resume Next
IsWorkbookOpen = Not Workbooks(strWB) Is Nothing
End Function
Sub speichern()
Dim c As Range
Dim feld As Range
datei = ActiveWorkbook.name
sumo = ActiveSheet.Cells(3, 2).Value
sudi = ActiveSheet.Cells(3, 4).Value
sumi = ActiveSheet.Cells(3, 6).Value
sudo = ActiveSheet.Cells(3, 8).Value
sufr = ActiveSheet.Cells(3, 10).Value
vegmo = ActiveSheet.Cells(4, 2).Value
vegdi = ActiveSheet.Cells(4, 4).Value
vegmi = ActiveSheet.Cells(4, 6).Value
vegdo = ActiveSheet.Cells(4, 8).Value
vegfr = ActiveSheet.Cells(4, 10).Value
hauptmo = ActiveSheet.Cells(6, 2).Value
hauptdi = ActiveSheet.Cells(6, 4).Value
hauptmi = ActiveSheet.Cells(6, 6).Value
hauptdo = ActiveSheet.Cells(6, 8).Value
hauptfr = ActiveSheet.Cells(6, 10).Value
menmo = ActiveSheet.Cells(8, 2).Value
mendi = ActiveSheet.Cells(8, 4).Value
menmi = ActiveSheet.Cells(8, 6).Value
mendo = ActiveSheet.Cells(8, 8).Value
menfr = ActiveSheet.Cells(8, 10).Value
bei1mo = ActiveSheet.Cells(11, 2).Value
bei1di = ActiveSheet.Cells(11, 4).Value
bei1mi = ActiveSheet.Cells(11, 6).Value
bei1do = ActiveSheet.Cells(11, 8).Value
bei1fr = ActiveSheet.Cells(11, 10).Value
bei2mo = ActiveSheet.Cells(12, 2).Value
bei2di = ActiveSheet.Cells(12, 4).Value
bei2mi = ActiveSheet.Cells(12, 6).Value
bei2do = ActiveSheet.Cells(12, 8).Value
bei2fr = ActiveSheet.Cells(12, 10).Value
If IsWorkbookOpen("Speiseplan Vorlage.xls") Then GoTo offen Else GoTo zu
offen:
Windows("Speiseplan Vorlage.xls").Activate
Sheets("Essensauswahl").Select
On Error GoTo ende
GoTo weiter
zu:
Workbooks.Open ("C:\Pfad\Speiseplan Vorlage.xls")
Sheets("Essensauswahl").Select
On Error GoTo ende
weiter:
For Each c In ActiveSheet.Range("a2:a65536")
If c.Value = sumo Then sumo = ""
If c.Value = sudi Then sudi = ""
If c.Value = sumi Then sumi = ""
If c.Value = sudo Then sudo = ""
If c.Value = sufr Then sufr = ""
Next c
ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Value = sumo
ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Value = sudi
ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Value = sumi
ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Value = sudo
ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0).Value = sufr
For Each c In ActiveSheet.Range("b2:b65536")
If c.Value = vegmo Then vegmo = ""
If c.Value = vegdi Then vegdi = ""
If c.Value = vegmi Then vegmi = ""
If c.Value = vegdo Then vegdo = ""
If c.Value = vegfr Then vegfr = ""
Next c
ActiveSheet.Range("b65536").End(xlUp).Offset(1, 0).Value = vegmo
ActiveSheet.Range("b65536").End(xlUp).Offset(1, 0).Value = vegdi
ActiveSheet.Range("b65536").End(xlUp).Offset(1, 0).Value = vegmi
ActiveSheet.Range("b65536").End(xlUp).Offset(1, 0).Value = vegdo
ActiveSheet.Range("b65536").End(xlUp).Offset(1, 0).Value = vegfr
For Each c In ActiveSheet.Range("c2:c65536")
If c.Value = hauptmo Then hauptmo = ""
If c.Value = hauptdi Then hauptdi = ""
If c.Value = hauptmi Then hauptmi = ""
If c.Value = hauptdo Then hauptdo = ""
If c.Value = hauptfr Then hauptfr = ""
Next c
ActiveSheet.Range("c65536").End(xlUp).Offset(1, 0).Value = hauptmo
ActiveSheet.Range("c65536").End(xlUp).Offset(1, 0).Value = hauptdi
ActiveSheet.Range("c65536").End(xlUp).Offset(1, 0).Value = hauptmi
ActiveSheet.Range("c65536").End(xlUp).Offset(1, 0).Value = hauptdo
ActiveSheet.Range("c65536").End(xlUp).Offset(1, 0).Value = hauptfr
For Each c In ActiveSheet.Range("d2:d65536")
If c.Value = menmo Then menmo = ""
If c.Value = mendi Then mendi = ""
If c.Value = menmi Then menmi = ""
If c.Value = mendo Then mendo = ""
If c.Value = menfr Then menfr = ""
Next c
ActiveSheet.Range("d65536").End(xlUp).Offset(1, 0).Value = menmo
ActiveSheet.Range("d65536").End(xlUp).Offset(1, 0).Value = mendi
ActiveSheet.Range("d65536").End(xlUp).Offset(1, 0).Value = menmi
ActiveSheet.Range("d65536").End(xlUp).Offset(1, 0).Value = mendo
ActiveSheet.Range("d65536").End(xlUp).Offset(1, 0).Value = menfr
For Each c In ActiveSheet.Range("e2:e65536")
If c.Value = bei1mo Then bei1mo = ""
If c.Value = bei1di Then bei1di = ""
If c.Value = bei1mi Then bei1mi = ""
If c.Value = bei1do Then bei1do = ""
If c.Value = bei1fr Then bei1fr = ""
If c.Value = bei2mo Then bei2mo = ""
If c.Value = bei2di Then bei2di = ""
If c.Value = bei2mi Then bei2mi = ""
If c.Value = bei2do Then bei2do = ""
If c.Value = bei2fr Then bei2fr = ""
Next c
ActiveSheet.Range("e65536").End(xlUp).Offset(1, 0).Value = bei1mo
ActiveSheet.Range("e65536").End(xlUp).Offset(1, 0).Value = bei1di
ActiveSheet.Range("e65536").End(xlUp).Offset(1, 0).Value = bei1mi
ActiveSheet.Range("e65536").End(xlUp).Offset(1, 0).Value = bei1do
ActiveSheet.Range("e65536").End(xlUp).Offset(1, 0).Value = bei1fr
ActiveSheet.Range("e65536").End(xlUp).Offset(1, 0).Value = bei2mo
ActiveSheet.Range("e65536").End(xlUp).Offset(1, 0).Value = bei2di
ActiveSheet.Range("e65536").End(xlUp).Offset(1, 0).Value = bei2mi
ActiveSheet.Range("e65536").End(xlUp).Offset(1, 0).Value = bei2do
ActiveSheet.Range("e65536").End(xlUp).Offset(1, 0).Value = bei2fr
ActiveSheet.Columns("A:iv").EntireColumn.AutoFit
ActiveSheet.Rows("1:65536").EntireRow.AutoFit
Application.Goto Reference:="Suppen"
Selection.Sort Key1:=Range("a2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.Goto Reference:="Vege"
Selection.Sort Key1:=Range("b2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.Goto Reference:="Haupt"
Selection.Sort Key1:=Range("c2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.Goto Reference:="Men"
Selection.Sort Key1:=Range("d2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Application.Goto Reference:="Beilagen"
Selection.Sort Key1:=Range("e2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
ActiveWorkbook.Save
Windows(datei).Activate
End Sub
Und wenn wir schon mal dabei sind:
Ist dieser Code so ok oder zu umständlich? Ich bin schon stolz, das er überhaupt funktioniert.
Gruss
Michael