Live-Forum - Die aktuellen Beiträge
Datum
Titel
18.04.2024 19:30:20
VBA - Tabelle mit Mannschaftsergebnissen sortieren
18.04.2024 18:04:29
Formel fehler Wert#
18.04.2024 17:45:21
Shellkommando ausführen, stderr auslesen
18.04.2024 17:41:41
Summe: Bestimmter Bereich mit sverweis
Du findest keine passende Antwort auf Deine Frage?
Stelle Deine Frage in unserem Live-Forum
Anzeige
Archiv - Navigation
840to844
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Vorheriger Thread
Vorheriger Thread
Rückwärts Blättern
840to844
840to844
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Nächster Thread
Nächster Thread
Vorwärts blättern
Inhaltsverzeichnis

Statusleiste Fortschritt Makro

Statusleiste Fortschritt Makro
26.01.2007 13:57:09
Michael
Liebe Profis!
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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Statusleiste Fortschritt Makro
26.01.2007 14:30:27
Rudi
Hallo,
1. ein Fortschritsbalken bremst dir nur den Code aus.
2. das sieht mir viel zu kompliziert aus. warum überprüfst du z.B.ganze Spalten, ob Werte vorhanden sind? z.B. hier:
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
Weiterhin wäre es sinnvoll, die Werte in Arrays zu schreiben und mit Schleifen zu arbeiten.
Dim vntSU(1 to 5), vntVEG(1 to 5)
for i=2 to 10 step 2
with activesheet
vntSU(i/2)=.cells(3,i)
vntVEG(i/2)=.cells(4,i)
'und noch die anderen
end with
next i
Gruß
Rudi
Eine Kuh macht Muh, viele Kühe machen Mühe
Anzeige
AW: Statusleiste Fortschritt Makro
26.01.2007 15:01:14
Michael
Danke zunächst mal für die Antwort. Den Balken will ich deshalb, weil es eine Zeitlang so ausieht, als würde nichts passieren, und ich will Bedienfehler eventueller Vertretungskräfte vermeiden.
Die ganzen Spalten checke ich, damit ich Gerichte nicht doppelt habe, und die Gültigkeitszuweisung ist nun mal a2 bis a65536, also kann theoretisch auch überall sowas schon drinstehen. Das wird ja evtl durch den von dir geschriebenen Code besser gelöst, allerdings bin ich bei:
"Weiterhin wäre es sinnvoll, die Werte in Arrays zu schreiben ..."
geistig ausgestiegen. Kannst du mir kurz erklären, was die Befehle:
Dim vntSU(1 to 5), vntVEG(1 to 5)
vntSU(i/2)=.cells(3,i)
vntVEG(i/2)=.cells(4,i)
machen, damit ich es für mich umsetzen kann?
Gruss Michael
Anzeige
AW: Statusleiste Fortschritt Makro
26.01.2007 14:59:02
Rudi
Hallo,
ungetestet:

Sub speichern()
Dim c As Range
Dim feld As Range
Dim vntSU(1 To 5), vntVEG(1 To 5), vntHAUPT(1 To 5), vntMEN(1 To 5), vntBEI1(1 To 5), vntBEI2(1 To 5)
Dim i As Integer, lngRow As Long
datei = ActiveWorkbook.Name
For i = 2 To 10 Step 2
vntSU(i / 2) = Cells(3, i)
vntVEG(i / 2) = Cells(4, i)
vntHAUPT(i / 2) = Cells(6, i)
vntMEN(i / 2) = Cells(8, i)
vntBEI1(i / 2) = Cells(11, i)
vntBEI2(i / 2) = Cells(12, i)
Next i
If IsWorkbookOpen("Speiseplan Vorlage.xls") Then
Windows("Speiseplan Vorlage.xls").Activate
Sheets("Essensauswahl").Select
Else
Workbooks.Open ("C:\Pfad\Speiseplan Vorlage.xls")
Sheets("Essensauswahl").Select
End If
On Error GoTo ende
For i = 1 To 5
If Not IsError(Application.Match(vntSU(i), Range("A:A"))) Then vntSU(i) = ""
Next i
lngRow = Range("A65536").End(xlUp).Row
Range(Cells(lngRow + 1, 1), Cells(lngRow + 5, 1)) = vntSU
For i = 1 To 5
If Not IsError(Application.Match(vntVEG(i), Range("B:B"))) Then vntVEG(i) = ""
Next i
lngRow = Range("b65536").End(xlUp).Row
Range(Cells(lngRow + 1, 2), Cells(lngRow + 5, 2)) = vntVEG
For i = 1 To 5
If Not IsError(Application.Match(vntHAUPT(i), Range("C:C"))) Then vntHAUPT(i) = ""
Next i
lngRow = Range("c65536").End(xlUp).Row
Range(Cells(lngRow + 1, 3), Cells(lngRow + 5, 3)) = vntHAUPT
For i = 1 To 5
If Not IsError(Application.Match(vntMEN(i), Range("D:D"))) Then vntMEN(i) = ""
Next i
lngRow = Range("D65536").End(xlUp).Row
Range(Cells(lngRow + 1, 4), Cells(lngRow + 5, 4)) = vntMEN
For i = 1 To 5
If Not IsError(Application.Match(vntBEI1(i), Range("E:E"))) Then vntBEI1(i) = ""
Next i
lngRow = Range("E65536").End(xlUp).Row
Range(Cells(lngRow + 1, 5), Cells(lngRow + 5, 5)) = vntBEI1
For i = 1 To 5
If Not IsError(Application.Match(vntBEI2(i), Range("E:E"))) Then vntBEI2(i) = ""
Next i
lngRow = Range("E65536").End(xlUp).Row
Range(Cells(lngRow + 1, 5), Cells(lngRow + 5, 5)) = vntBEI2
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

Gruß
Rudi
Eine Kuh macht Muh, viele Kühe machen Mühe
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Jetzt das Excel-Portal bewerten: Deine Stimme zählt!

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige