Laufbalken an VBA Code koppeln

[Bernie]

Hallo André,

schön das du mir helfen möchtest. Das mit dem Laufbalken ist noch ein wenig zu hoch für mich.

Hier ist mein aktueller Code:

Code:

Sub webabfrage_indizes()
    Dim lngC As Long
    Dim vntArray As Variant
    
    vntArray = Array("Abf_Dax", "Abf_TECDAX", "Abf_MDAX", "Abf_DOWJONES", "AbfrageDAX", "AbfrageTECDAX", "AbfrageMDAX", "AbfrageDOWJONES", "Abf_Währung")
    frm_warten.Show
    Application.ScreenUpdating = False
    For lngC = 0 To UBound(vntArray)
        Worksheets(vntArray(lngC)).QueryTables(1).Refresh BackgroundQuery:=False
    Next lngC
    Call filter_top
    frm_ende.Show
    Sheets("Depot").Activate
    Range("A1").Select
    Application.ScreenUpdating = True
End Sub

Sub filter_top()
    Sheets("Top10").Select
    Range("B2:C2").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort.SortFields.Add Key:=Range( _
        "C2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("F2:G2").Select
    Selection.AutoFilter
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort.SortFields.Add Key:=Range( _
        "G2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Selection.AutoFilter
    Range("J2:K2").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort.SortFields.Add Key:=Range( _
        "K2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Selection.AutoFilter
    Range("N2:O2").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort.SortFields.Add Key:=Range( _
        "O2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Selection.AutoFilter
    Range("R2:S2").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort.SortFields.Add Key:=Range( _
        "S2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Top10").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Selection.AutoFilter
    Range("A1").Select
End Sub

Wie du siehst lasse ich kleine UF's (frm_warten) starten (3Sek.) mit Label "Daten werden aktualisiert!". Und am Ende eine weitere UF mit Text "Aktualisierung beendet".

Wie muss ich den Code ändern, um einen Laufbalken in die UF's einzufügen und genau am Ende der Aktualisierung der Laufbalken und somit die UF schließt?

[schauan]

Hallo Bernie,

wird heute leider nichts mehr. Ich melde mich aber morgen Abend wieder...

[Steffl]

Hallo Bernd,

und wo ist nun der grosse Zeitfresser?

[Bernie]

Hi Stefan,

so wie ich das beurteilen kann, hier:

Code:

vntArray = Array("Abf_Dax", "Abf_TECDAX", "Abf_MDAX", "Abf_DOWJONES", "AbfrageDAX", "AbfrageTECDAX", "AbfrageMDAX", "AbfrageDOWJONES", "Abf_Währung")

Denn bis alle Tabellenblätter abgearbeiten werden dauert es ca. 50-60 sek. und es darf in der Zeit nichts anderes gemacht werden, sonst hängt sich Excel auf.

[Steffl]

Hallo Bernd,

diese Codezeile ist es mit Sicherheit nicht. Ich habe in diesem Beitrag meinen Code geändert und lasse hier die Zeit im Direktfenster ausgeben. Sage mir doch was da raus kommt.

[Bernie]

Hallo Stefan,

hab deinen Code ausprobiert, es dauert nur noch 10 Sekunden. Hier die Werte aus dem Direktfenster:

Code:

Tabellen einblenden  0
QueryTables  9,78125
Filter top  0
Tabellen ausblenden  0,015625

Hab mal ne Datei aus dem Web gedownloadet, sei mal so nett und schau sie dir an. Insbesondere das Beispiel 1. Da hab ich es her mit dem Laufbalken.

[Rabe]

Hi Bernie,

Hab mal ne Datei aus dem Web gedownloadet, sei mal so nett und schau sie dir an. Insbesondere das Beispiel 1. Da hab ich es her mit dem Laufbalken.

das Beispiel 1 habe ich mir mal vor einigen Jahren in eine Datei eingebaut und sie funktioniert sehr gut: Ich habe einen Bereich von 50 Spalten und 30 Zeilen, bei denen in Schleifendurchläufen abhängig von Zellfarbe und Inhalt diverse Zähler hochgezählt wird. Nun kann ich den Balken bei jedem Schleifendurchgang jeweils um 1/1500 anwachsen lassen.

Das (und damit Dein) Problem ist, wenn Du nichts zum Zählen hast, kann die Userform und der Fortschrittsbalken nicht wissen, wie viel Schritte es insgesamt sind und wie die Schrittweite ist, sowie wieviel Prozent der Aufgabe schon abgearbeitet sind, deswegen kann der Balken nicht kontinuierlich laufen.

Mit Deiner Beispiel-Aufgabe:

Code:

vntArray = Array("Abf_Dax", "Abf_TECDAX", "Abf_MDAX", "Abf_DOWJONES", "AbfrageDAX", "AbfrageTECDAX", "AbfrageMDAX", "AbfrageDOWJONES", "Abf_Währung")

könntest Du nur gewissermaßen jeweils nach Abarbeitung der einzelnen Tabellenblätter den Balken ein Neuntel (11%) anwachsen lassen.

[Steffl]

Hallo Bernd,

habe mal den Code von dem Beispiel 1 geändert. Wenn Du die Userform in deine Datei mit einbaust mußt Du natürlich die Bezeichnungen für die Labels so übernehmen bzw. anpassen.

Code:

Sub Progressbar1()
   Dim lngC As Long
   Dim vntArray As Variant
   Dim dblSchritt As Double, dblDauer As Double

   vntArray = Array("Abf_Dax", "Abf_TECDAX", "Abf_MDAX", "Abf_DOWJONES", "AbfrageDAX", "AbfrageTECDAX", "AbfrageMDAX", "AbfrageDOWJONES")
   Application.ScreenUpdating = False
   Call tabellen_einblenden
   dblSchritt = PB1.Label1.Width / (UBound(vntArray) + 1)
   For lngC = 0 To UBound(vntArray)
      Worksheets(vntArray(lngC)).QueryTables(1).Refresh BackgroundQuery:=False
      dblDauer = dblDauer + dblSchritt
      PB1.Label2.Width = dblDauer
      PB1.Label3.Caption = Format(PB1.Label2.Width / PB1.Label1.Width, "0 %")
'      Application.Wait Now + TimeValue("0:00:02")
      DoEvents
   Next lngC
   Call filter_top
   Call tabellen_ausblenden
'   MsgBox "Ich bin fertig", vbInformation
   Application.ScreenUpdating = True
   Unload PB1
End Sub

Und noch die Datei

[schauan]

Hallo Bernie,

ich habe hier ein Beispiel auf Basis von Deinem code von gestern, 20:39 Uhr.

Das von Stefan hab ich mir noch nicht angeschaut, hab gerade erst gesehen, dass er auch eine Excel-Datei hier im Forum eingestellt hat.

Zum Start einfach den Button auf dem Tabellenblatt drücken. Zuerst wird das Userform aufgerufen, dieses startet dann den Import.

Ich habe ein paar codezeilen von Dir auskommentiert, da ja die Makros und der WEB-Import nicht dabei waren. Dafür hab ich noch ein sleep mit drin, damit es nicht einfach durchwackelt. Das muss wieder raus und oben die zugehörigen API-Funktionen.

Ich hab das so drin, das die ersten Prozente nach dem ersten Import angezeigt werden. Dadurch werden die 100% erst am ende erreicht und gleich danach kommt die Fertigmeldung. Man könnt es auch vor dem Import hochsetzen, siehe die auskommentierte Zeile

[Bernie]

@Ralf, Stefan und André,

habe gerade Zeit gefunden ins Forum zu kommen und eure Dateien runter geladen. Diesbezüglich werde ich mich erst am Montag wieder melden können, da ich beruflich sehr eingesapannt bin.

Eines muss ich aber unbedingt noch los werden,

+++++ SCHÖN, DASS ES EUCH GIBT!!!!! +++++++++

Bis Montag.