Ladebalken beim Ausführern längeren VBA-Schritten

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet If Not (Target.Address = "$K$3") Then Exit Sub For Each ws In ThisWorkbook.Worksheets If Left(ws.Name, 3) = "Tmw" Then If IsDate(Target.Value) Then ws.Range("C378").Value = Left(Target.Value, Len(Target.Value) - 3) & "" Else ws.Range("C378").Value = Target.Value End If End If Next ActiveSheet.PivotTables("REA Messwerte").RefreshTable End Sub

Hallo
also ich hab mal versucht, die Balkenanzeige zu integrieren, der Code sieht dann so aus:


Private Sub Worksheet_Change(ByVal Target As Range)
Dim ws As Worksheet
If Not (Target.Address = "$K$4") Then Exit Sub
'    Dim Länge As Single
'    Dim i As Long
'    Dim Anz As Long
'    Dim zeit As Date
'    With ActiveSheet
'        .Shapes("Hülle").Visible = True
'        .Shapes("Überschrift").Visible = True
'        .Shapes("Balken").Visible = True
'        .Shapes("Hintergrund").Visible = True
'    End With
'    Länge = ActiveSheet.Shapes("Hülle").Width
'    Anz = 7
'    ActiveSheet.Shapes("Balken").Width = 0
'   i = 0
For Each ws In ThisWorkbook.Worksheets
If Left(ws.Name, 3) = "Tmw" Then
'           i = i + 1
'           ActiveSheet.Shapes("Balken").Width = Länge * i / Anz
If IsDate(Target.Value) Then
ws.Range("C372").Value = Left(Target.Value, Len(Target.Value) - 3) & ""
Else
ws.Range("C372").Value = Target.Value
End If
End If
Next
'   i = i + 1
'   ActiveSheet.Shapes("Balken").Width = Länge * i / Anz
ActiveSheet.PivotTables("REA Messwerte").RefreshTable
'With ActiveSheet
'    .Shapes("Hülle").Visible = False
'    .Shapes("Überschrift").Visible = False
'    .Shapes("Balken").Visible = False
'    .Shapes("Hintergrund").Visible = False
'End With
End Sub

die von mir eingefügten Bestandteile habe ich zu kennzeichnung auskommentiert, dh. wenn du damit arbeiten willst, mußt du die Hochkommas entfernen.
desweiteren musst du die Grafikelemente noch von Hand in deine Datei einfügen und ihnen die gleichen Namen geben, wie sie auch im Code verwendet werden.
Am einfachsten kopierst du sie aus meiner Beispieldatei raus. dazu im Code den letzten Withblock löschen (da wo visible = false gestetzt wird) und den code einmal laufen lassen. dann kannst du die Elemente in deine Datei kopieren
Gruß, Daniel

Hallo Daniel,
also das Application.Screenupdating = true funktioniert und löst schonmal das Probelm mit der Anzeige der Balkenveränderung. Danke für den guten Tip!
Habe dann deine Prozentzeile eingefügt wie du angegeben hattest und das ganze durchlaufen lassen. Nun wird der Prozentwert richtig gezählt und angezeigt, daher auch hier danke für deine gute Idee ^^
Optische Verschönerung:
Ich würde mir nur noch eine optische Verschönerung wünschen. Zur Zeit ist der Prozentfortschritt so definiert, dass dieser immer Stück für Stück mitrückt bis zur Mitte (zentriert eingestellt) und dann dort stehen bleibt wenn der Balken voll ist bei 100%. Nun habe ich noch das Wort "abgeschlossen" hinter dem %-Zeichen eingefügt und am Anfang wird ein Teil dieses Wortes wie beim Zeilenumbruch einfach nach unten geworfen, da der Balken ja noch wächst bevor es in der selben Zeile komplett dargestellt werden kann. Daher würde ich es begrüßen, wenn der %-Wert + "% abgeschlossen" immer vertikal und horizontal zentriert im Hintergrund stehen, ohne sich mitzubewegen wenn der Balken läuft. Natürlich soll der %-Wert aber weiter ansteigen!
Hast hier nochmal einen heißen Tip für mich bitte?
Gruß,
Ronny

Private Sub Worksheet_Change(ByVal Target As Range) Dim ws As Worksheet Dim prozWert as Double prozWert = 12.5 If Not (Target.Address = "$K$3") Then Exit Sub For Each ws In ThisWorkbook.Worksheets Application.Statusbar = "Total erledigte Tabellen: " & prozWert & "% prozWert = prozWert + 12.5 If Left(ws.Name, 3) = "Tmw" Then If IsDate(Target.Value) Then ws.Range("C378").Value = Left(Target.Value, Len(Target.Value) - 3) & "" Else ws.Range("C378").Value = Target.Value End If End If Next ActiveSheet.PivotTables("REA Messwerte").RefreshTable Application.Statusbar = False End Sub

Beliebteste Forumthreads (12 Monate)

Ladebalken beim Ausführern längeren VBA-Schritten

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Ladebalken beim Ausführern längeren VBA-Schritten

26 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread