ProgressBar in makro's verwerken

Status
Niet open voor verdere reacties.
E

ExcelTonnie

Gebruiker
Lid geworden
5 jul 2016
Berichten
317
Op Youtube een mooie progressBar gezien die ik graag in sommige van mijn files zou willen gebruiken.
Zie hier voorbeeld
HTML: 
https://www.youtube.com/watch?v=LhNzsdPtLoo&t=280s

De code volledige overgenomen echter werkt het niet bij mij en kan niet vinden wat er nu anders is.

Progje in de bijlage toegevoegd.

Code voor de progressBar en een Module om te testen dmv waarden af te drukken in een kolom.


Programma code
Code: 
Sub progress(i As Long, llast As Long)

Dim pctCompl As Single

pctCompl = Round(i / llast * 100, 0)
Progression.Label1.Caption = i & "/" & llast
Progression.Text.Caption = pctCompl & "% Completed"
Progression.Bar.Width = pctCompl * 2

DoEvents






End Sub



Code om te testen
Code: 
Option Explicit

Sub main()

            
Dim clock As Double
Dim i As Long
Dim colA As Range, cel As Range

 Progression.Show

clock = Timer


With ThisWorkbook.Sheets(1)

    For i = 1 To 10000
     
   
      .Cells(i, 3) = 1
        
      Call progress(i, 10000)
   
    Next
    Debug.Print Round(Timer = clock, 3)
    
End With

Unload Progression



End Sub


Welke Expert kan hier iets mee.
 

Bijlagen

Wijzig:
Progression.Show

In:
Progression.Show (False)
 
Sorry Edmoor maar ik snap niet wat je daar nou precies mee bedoelt.
Zou je het iets anders kunnen formulieren waar ik iets moet veranderen.
Denk dat ik in de module Progression iets moet wijzigen maar snap niet precies hoe.
 
Volgens mij staat het er toch wel erg duidelijk:
Code: 
Option Explicit

Sub main()

            
Dim clock As Double
Dim i As Long
Dim colA As Range, cel As Range

 Progression.Show [COLOR="#FF0000"](False)[/COLOR]

clock = Timer


With ThisWorkbook.Sheets(1)

    For i = 1 To 10000
     
   
      .Cells(i, 3) = 1
        
      Call progress(i, 10000)
   
    Next
    Debug.Print Round(Timer = clock, 3)
    
End With

Unload Progression



End Sub
 
Waarom je code vertragen met een voortgangsbalk ?
 
Edmoor

Super het werkt, probeer de code te begrijpen wat het nu precies aan het doen is.
Ben nog echt maar een beginneling maar vindt het super interessant.
Wederom bedankt voor je hulp.

Groet Tonnie
 
snb zei:
Waarom je code vertragen met een voortgangsbalk ?
Klik om te vergroten...

Ik wil dit in andere bestand gaan gebruiken waar diverse macro's (call) inzitten en het scherm alleen maar flikkert en sommigen twijfelen of het systeem wel wat doet.
 
Dan moet je daaraan wat doen: de code sneller maken, screenupdating uitzetten, van array gebruik maken.
 
Weet het dat ik daar wat aan zou moeten doen en ben hierin ook nog lerende.
Wel vind ik het ook leuk staan zo'n indicator.
 
Ik houd niet van zinloos wachten.....
 
zelfde mening als snb, screenupdating uitzetten etc om code sneller te laten lopen.
Daarnaast kan je als vorm van progress dan huidige toestand meegeven in de statusbalk
Code: 
Sub MijnStatusbar()
   Application.ScreenUpdating = False
   
   imax = 100000 'aantal loops
      For i = 1 To imax
      If i Mod 1000 = 0 Then Application.StatusBar = Space(10) & "Bezig met loop nummer " & Format(i, "#,###") & " van " & Format(imax, "#,###")
      Range("A1").Value = i
   Next
   
   Application.StatusBar = ""
   Application.ScreenUpdating = True

End Sub
 
Jullie mening is duidelijk en goed bedoeld natuurlijk.
Er zal een bepaalde vertraging optreden wanneer er een progressbar wordt geplaatst maar vindt dat de gebruiker moeten kunnen zien dat er iets gebeurt.

Durf te vragen....
Wat ik graag zou willen is dat de progressbar progje tussen de code te plaatsen, gewoon om aan te geven.
Heb een klein deel van de code ingevoegd om een idee te geven wat er allemaal gebeurt. (code is dus veel uitgebreider)
Het ophalen van de txt gebeurt met 9 verschillende files.
Vandaar dat ik het leuk vindt om een voortgangsindicator te tonen in een popup ipv de statusbalk (die valt minder op)
De progressbar hoeft alleen maar een indicator met % verloop te tonen.
Waarschijnlijk roep ik weer een boel weerstand op.



Code: 
Sub Gage1()
If Dir("S:\QADeventer\Edward\Solex4gageRenR\Tekstfiles\Nieuw GageR&R\R&RTEST10000.txt") <> "" Then
 
        MsgBox "Files zijn aanwezig, u gaat verder nadat u op OK drukt!", vbInformation, "Controle op aanwezige files"
Sheets("Import").Select
    ActiveSheet.Unprotect "*****"
    Cells.Select
    Selection.ClearContents
    Range("A1").Select


With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;S:\QADeventer\Edward\Solex4gageRenR\Tekstfiles\Nieuw GageR&R\R&RTEST10000.txt" _
        , Destination:=Range("$A$1"))
        '.CommandType = 0
        .Name = "R&RTEST10000"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True

        .Refresh BackgroundQuery:=False
    End With
    Range("A14").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;S:\QADeventer\Edward\Solex4gageRenR\Tekstfiles\Nieuw GageR&R\R&RTEST20000.txt" _
        , Destination:=Range("$A$14"))
        '.CommandType = 0
        .Name = "R&RTEST20000"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
 
tja, als je 9 stappen hebt, dan zal je 9 keer dat zaakje moeten aanroepen
de eerste keer met
Code: 
 Call progress(0, 9)
, de keer erop wordt die 0 een 1, etc.
 

Bijlagen

Laatst bewerkt:
Denk niet dat het duidelijk is wat ik precies bedoel en of het überhaupt mogelijk is.

Bij start van de macro moet de ProgressBar verschijnen en de bar gaan lopen en tot 100% komen aan het einde van de macro.
Zoals ik het nu getest heb start en stopt die na elk deel dat wordt ingeladen, na het sluiten met kruisje (R.boven) gaat de indicator verder naar de volgende en stopt weer.
Weet niet hoe ik dit verder zou moeten invullen.



Code: 
[B]Progression.Show
Call progress(0, 9)[/B]
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;S:\QADeventer\Edward\Solex4gageRenR\Tekstfiles\Nieuw GageR&R\R&RTEST10000.txt" _
        , Destination:=Range("$A$1"))
        '.CommandType = 0
        .Name = "R&RTEST10000"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True

        .Refresh BackgroundQuery:=False
    End With
    Range("A14").Select
[B]Progression.Show
Call progress(1, 9)[/B]

    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;S:\QADeventer\Edward\Solex4gageRenR\Tekstfiles\Nieuw GageR&R\R&RTEST20000.txt" _
        , Destination:=Range("$A$14"))
        '.CommandType = 0
        .Name = "R&RTEST20000"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    ActiveWindow.SmallScroll Down:=3
    Range("A27").Select


enz. enz.
 
Querytabels hoef je maar 1 keer in te voeren; daarna hoef je ze alleen maar te verversen (refresh).
Een je kunt instellen dat dat automatisch gebeurt bij het openen van het bestand: het exacte aantal benodigde VBA-coderegels is dan 0.

Vermijd iedere 'Select' en 'Activate' in VBA-code.
Zoek eens op wat 'default' betekent.
 
Laatst bewerkt:
Onderstaande code zou ik op de juiste plaatsen in voegen
Code: 
    Application.StatusBar = "Updating... Querytable 1"
    Application.StatusBar = "Updating... Querytable 2"
    Application.StatusBar = "Ready"
Aan het veranderen van de tekst kan je al zien dat de code niet vastgelopen is, dat is voor mij al voldoende.
Stel dat je in een andere code een tellertje had, dan zou je dat telltertje in van statusbar kunnen laten zien.
Code: 
Application.StatusBar = "Updating... " & lRegel & " van " & lRegels & "."
Maar bij een querytabel heb je geen tellertje.
 
Laatst bewerkt:
Jammer dat het meer over de bestaande code gaat dan over de progressBar.
Helaas kan ik met jullie adviezen niets.
Kom hier niet verder mee.
Bedankt voor jullie adviezen.
 
cow18 zei:
tja, als je 9 stappen hebt, dan zal je 9 keer dat zaakje moeten aanroepen
de eerste keer met
Code: 
 Call progress(0, 9)
, de keer erop wordt die 0 een 1, etc.
Klik om te vergroten...

Call progress tussengevoegd, enkel stopt die elke keer met de volgende en moet dan sluiten met kruisje.
ZOu mooi zijn als het mogelijk zou zijn dat die gewoon doorloopt tot einde.

K1.JPGK2.JPGK3.JPG
 
Je gebruikt het ook helemaal fout.
Wat je hebt is slechts een voorbeeld.
Je moet dus het bijwerken van de voorgang in je proces inbouwen, zoals in dit voorbeeld:
Bekijk bijlage Voortgang.xlsm

In plaats van:
Code: 
Application.Wait (Now() + TimeValue("00:00:01"))
gebruik je dan de code die per stap moet worden uitgevoerd.
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan