Barre de progression liée au défilement des lignes de code

jp65 · 26 Avril 2014

Bonjour le forum

Voici ma question.
J'ai une macro dont je voudrais visualiser le déroulement avec une barre de progression.
La macro comprend une boucle et de nombreuses mises en forme.
Est-il possible de lier la barre de progression à chaque ligne de code (et non au résultat) qui s'exécute. En gros de la même
manière que ce qui est fait avec la touche F8 quand on exécute la macro en manuel.

Il y a de nombreux exemples de barregraphe sur le net mais j'avoue que l'intégration dans un code m’apparaît
plutôt obscur.

Merci par avance pour toute aide

Staple1600 · 26 Avril 2014

Re : Barre de progression liée au défilement des lignes de code

Bonjour à tous

jp65 (Bienvenue sur le forum)
Voici ma réponse

Difficile de te répondre sans voir ton code VBA
Plus facile de te répondre si tu joins un fichier exemple avec le code VBA dans ta discussion.

jp65 · 26 Avril 2014

Re : Barre de progression liée au défilement des lignes de code

Bonjour Staple 1600

Merci pour ton attention.

Voici ma macro qui effectue une boucle pour récupérer des infos dans plusieurs fichiers texte et qui les intègre lignes par lignes dans mon classeur excel. La suite (qui prend le plus de place en nombre de lignes de code) est une mise en forme et quelques calculs.

Code:

Option Explicit

Sub Trouvertexte()


Dim Feuil1 As Object
Dim dc As String
Dim ch As String
Dim S As String
Dim s1 As String
Dim f As String
Dim l As String
Dim T As String
Dim i As Integer
Dim p As String
Dim vp As String
Dim objShell As Object
Dim objFolder As Object
Dim trouvé As Boolean
'Variables liées à la mise en forme
Dim x As Integer
Dim y As Integer
Dim u As String
Dim c As Variant
Dim monDico As Object
Dim temp As String
Dim MyRange As Object
Dim cell As Variant
Dim dl As Integer

Application.ScreenUpdating = False
 Range("A2").Select
    ActiveCell.FormulaR1C1 = "Début du test"
    Range("B2").Select
    ActiveCell.FormulaR1C1 = "Nom de l'opérateur"
    Range("C2").Select
    ActiveCell.FormulaR1C1 = "Numéro de série"
    Range("D2").Select
    ActiveCell.FormulaR1C1 = "Référence du produit"
    Range("E2").Select
    ActiveCell.FormulaR1C1 = "Référence du programme"
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "Rigidité AC entre groupes"
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "Fin du test"
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "TEST"
    Columns("A:M").EntireColumn.AutoFit
    Rows("2:2").Select
    With Selection
        .HorizontalAlignment = xlGeneral
        .VerticalAlignment = xlBottom
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
' Résultat feuille avec paramètres et résultats
 Set Feuil1 = Worksheets("Feuil1")
 
' dc = dernière colonne utlisée dans Feuil1
 dc = Feuil1.Range("ZA2").End(xlToLeft).Column
      Set objShell = CreateObject("Shell.Application")
      
'Ouvre une fenêtre Window pour sélectionner le dossier
      Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
      
 'Si l'utilisateur annule sans choisir
      If objFolder Is Nothing Then
      
 'message
      MsgBox "Abandon opérateur", vbCritical, "Annulation"
      
 'sinon
      Else
      
 'Ch = répertoire choisi
      ch = objFolder.ParentFolder.ParseName(objFolder.Title).Path & "\"
      
'Pour accéder directement au dossier sans passer par le menu
' ch = répertoire dans lequel chercher les fichiers
      'ch = "C:\Users\JP\Desktop\Résultats txt\"
 ' on cherche le dernier "\" à sa gauche on aura le chemin d'accès (répertoire)
' à sa droite le nom du fichier
 S = InStr(ch, "\")
    While S <> 0
    s1 = InStr(S + 1, ch, "\")
 ' on a trouvé le dernier "\"
 
 If s1 = 0 Then
 ' on sauve le répertoire
 ch = Left(ch, S)
    End If
    S = s1
    Wend
' f contient le nom du premier fichier correspondant au filtre
 f = Dir(ch)
 
' l pointeur de ligne en cours sur Résultat
 l = 2
 
 'tant qu'il y a un fichier
 While f <> ""
        trouvé = False
        
 ' on ouvre le fichier
     Open ch & f For Input As #1
     
 ' on écrit le nom du fichier en cours sur Résultat
     'Résultat.Cells(l, 1) = f
' on charge le contenu du fichier dans t
While Not EOF(1)
       Line Input #1, T
       
 ' on parcourt tous les paramètres
     For i = 1 To dc
     
 ' p est le paramètre en cours
         p = Feuil1.Cells(2, i)
         
 ' on cherche p dans t
         S = InStr(UCase(T), UCase(p))
         
 ' on a trouvé p dans t
         If S <> 0 Then
               If trouvé = False Then trouvé = True: l = l + 1
               vp = Mid(T, S + Len(p))
               
 ' cas spécial du numéro de série
 '15 est le nombre de lettres et espace
              If Left(p, 15) = "Numéro de série" Then
                s1 = InStr(vp, ",")
                If s1 <> 0 Then
                 vp = Replace(vp, Left(vp, s1), "")
                End If
               End If
               
 ' cas spécial du diélectrique
 '100 est le nombre de lettres et espace
              If Left(p, 100) = "Rigidité AC entre groupes" Then
                s1 = InStr(vp, " - ")
                If s1 <> 0 Then
                 vp = Replace(vp, Left(vp, s1), "")
                End If
               End If
               
 ' on met vp dans Résultat après l'avoir "nettoyé"
             Feuil1.Cells(l, i) = Application.WorksheetFunction.Clean(Trim(Replace(Replace(vp, "=", ""), ":", "")))
                vp = ""
                Exit For
            End If
        Next i
          Wend
        Close 1
      
 ' on prend le fichier suivant qui correspond au filtre
     f = Dir()
    Wend
    Set Feuil1 = Nothing
    End If
    
'Déplacement colonne Référence du produit en A
    Columns("D:D").Select
    Selection.Cut
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    
'Déplacement colonne Début du test en G
    Columns("B:B").Select
    Selection.Cut
    Columns("G:G").Select
    Selection.Insert Shift:=xlToRight
    
'Déplacement colonne TEST en B
    Columns("H:H").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    
'Déplacement colonne Numéro de série en B
    Columns("D:D").Select
    Selection.Cut
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    
'Déplacement colonne Rigidité AC entre groupes en D
    Columns("F:F").Select
    Selection.Cut
    Columns("D:D").Select
    Selection.Insert Shift:=xlToRight
    
'Efface le contenu de G2
    Range("G2:H2").Select
    Selection.ClearContents
    
'Insertion de d'une colonne avant E
    Columns("E:E").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
'Application d'un filtre pour séparer "-" avec le résultat du diélectrique
    Range("D2").Select
    Selection.ClearContents
    Columns("D:D").Select
    Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Columns("D:D").Select
    Selection.Delete Shift:=xlToLeft
    
'Inscription "Diélectrique" en entête de la colonne D
    Range("D2").Select
    ActiveCell.FormulaR1C1 = "Diélectrique"
    
'Insertion de deux colonnes avant H
    Columns("H:H").Select
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
    
'Application d'un filtre pour séparer "-" avec "date" avec "heure"
'TESTER Range("G3:G" & [G65000].End(xlUp).Select)
   Range("G3:G65000").Select
    Application.CutCopyMode = False
    Selection.TextToColumns Destination:=Range("G3"), DataType:=xlFixedWidth, _
    FieldInfo:=Array(Array(0, 1), Array(1, 4), Array(12, 2)), TrailingMinusNumbers:=True
    
'Suppression de la colonne contenent les "-"
    Columns("G:G").Select
    Selection.Delete Shift:=xlToLeft
    
'Inscription "Date du test" en entête de la colonne F
    Range("G2").Select
    ActiveCell.FormulaR1C1 = "Date du test"
    
'Reformatage des heures en hh:mm:ss en colonne H
    For x = 3 To Range("H65536").End(xlUp).Row
    u = Range("H" & x)
    Range("H" & x) = Left(u, 2) & ":" & Mid(u, 3, 2) & ":" & Right(u, 2)
    Next
    
'Inscription "Début du test" en entête de la colonne H
    Range("H2").Select
    ActiveCell.FormulaR1C1 = "Début du test"
    
'Format de cellule hh:mm:ss pour la colonne H
    Columns("H:H").Select
    Selection.NumberFormat = "h:mm:ss;@"
    
'Application d'un filtre pour séparer "-" avec "date" avec "heure"
'TESTER Range("I3:I" & [I65000].End(xlUp).Select)
   Range("I3:I65000").Select
    Selection.TextToColumns Destination:=Range("I3"), DataType:=xlFixedWidth, _
        FieldInfo:=Array(Array(0, 1), Array(1, 4), Array(12, 2)), TrailingMinusNumbers:=True
        
'Suppression de la colonne I et J
    Columns("I:J").Select
    Selection.Delete Shift:=xlToLeft
    
'Reformatage des heures en hh:mm:ss en colonne I
    For y = 3 To Range("H65536").End(xlUp).Row
    u = Range("I" & y)
    Range("I" & y) = Left(u, 2) & ":" & Mid(u, 3, 2) & ":" & Right(u, 2)
    Next
    
'Inscription "Fin du test" en entête de la colonne I
    Range("I2").Select
    ActiveCell.FormulaR1C1 = "Fin du test"
    
'Format de cellule hh:mm:ss pour la colonne I
    Columns("I:I").Select
    Selection.NumberFormat = "h:mm:ss;@"
    
'Inscrit en colonne J la différence entre fin du test et début du test
    Intersect(ActiveSheet.UsedRange.EntireRow, [J:J]).FormulaR1C1 = "=RC[-1]-RC[-2]"

'Inscription "Durée du test" en entête de la colonne J
    Range("J2").Select
    ActiveCell.FormulaR1C1 = "Durée du test"

'Centrage de toutes les cellules
    Columns("A:A").ColumnWidth = 18
    Columns("B:B").ColumnWidth = 13
    Columns("C:C").ColumnWidth = 16
    Columns("D:D").ColumnWidth = 12
    Columns("E:E").ColumnWidth = 10
    Columns("F:F").ColumnWidth = 22
    Columns("G:G").ColumnWidth = 12
    Columns("H:H").ColumnWidth = 12
    Columns("I:I").ColumnWidth = 12
    Columns("J:J").ColumnWidth = 12
    Columns("K:K").ColumnWidth = 12
    Rows("2:2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.RowHeight = 30
    Columns("D:D").ColumnWidth = 12
    Columns("A:M").HorizontalAlignment = xlCenter

'Fige les lignes 1 et 2
    Range("A3").Select
        ActiveWindow.FreezePanes = True
        
'Quadrillage du tableau
    Columns("A:K").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
        .ColorIndex = xlAutomatic
        .TintAndShade = 0
        .Weight = xlThin
    End With
    Range("K20").Select
 
'Tri ascendant de la colonne G avec H (Date / heure)
   Sheets("Feuil1").[G3].Sort Key1:=Sheets("Feuil1").[G3], Order1:=xlAscending, _
       key2:=Sheets("Feuil1").[H3], Order2:=xlAscending, Header:=xlGuess
       
'Tri ascendant de la colonne A avec B (Référence / N° série)
   Sheets("Feuil1").[A3].Sort Key1:=Sheets("Feuil1").[A3], Order1:=xlAscending, _
       key2:=Sheets("Feuil1").[B3], Order2:=xlAscending, Header:=xlGuess
       
'Calcule la différence entre le temps de début d'une ligne par rapport
'au temps de fin de la ligne précédente
 Intersect(ActiveSheet.UsedRange.EntireRow, [K:K]).FormulaR1C1 = "=RC[-3]-R[-1]C[-2]"
  
'Copie la colonne K en L pour garder la valeur et effacer le calcul
Columns("K:K").Select
    Selection.Copy
    Columns("L:L").Select
    Selection.PasteSpecial Paste:=xlPasteAllUsingSourceTheme, Operation:=xlNone _
        , SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False

'Détecte la première occurence des numéros (marquage x en colonne M
    Intersect(ActiveSheet.UsedRange.EntireRow, [M:M]).FormulaR1C1 = _
    "=IF(R[-1]C[-11]=RC[-11],"""",""x"")"
    
'Efface la cellule à gauche du marquage x
For Each c In [M3:M65000]
If c = "x" Then
c.Offset(0, -1).ClearContents
End If
Next c

'Efface les colonnes K et ensuite L
Columns("K:K").Select
    Selection.Delete Shift:=xlToLeft
    Columns("L:L").Select
    Selection.Delete Shift:=xlToLeft

'Efface les cellules négatives de la colonne K
Range("K2").Select
    Selection.ClearContents
dl = Range("K65536").End(xlUp).Row 'définit la variable x (dernière ligne remplie (colonne à adapter))
For x = dl To 1 Step -1 'boucle inversée sur toutes les lignes x
    'si la cellule de la ligne x, colonne 9 ("I") est vide ou si la cellule de la ligne x
    'colonne 14 ("N") est négative, supprime la ligne
    If Cells(x, 11).Value < 0 Then Cells(x, 11).ClearContents
Next x 'prochaine ligne de la boucle

'Colore en orange les doublons d'une série sauf le dernier
'Colore en vert le dernier doublon de la série
  Set monDico = CreateObject("Scripting.Dictionary")
  Application.ScreenUpdating = False
  i = Range("a" & Rows.Count).End(xlUp).Row
  Do While i > 2
    temp = Cells(i, "A") & Cells(i, "B")
    If Not monDico.exists(temp) Then
      monDico(temp) = ""
      If temp = Cells(i - 1, "A") & Cells(i - 1, "B") Then
       Rows(i).Resize(, Range("a" & i).CurrentRegion.Columns.Count). _
       Interior.ColorIndex = 35 '35 = vert
      End If
      i = i - 1
    Else
      Rows(i).Resize(, Range("a" & i).CurrentRegion.Columns.Count). _
      Interior.ColorIndex = 40 '40 = orange
    i = i - 1
   End If
  Loop
  
'Colorie en bleu les lignes contenant "MAUVAIS" pour isoler les soucis diélectriques fantômes
    For i = Range("a" & Rows.Count).End(xlUp).Row To 4 Step -1
        If Range("a" & i).Offset(, 2) = "MAUVAIS" And Range("a" & i).Offset(, 3) = "MAUVAIS" Then
           Range("a" & i).Resize(, Range("a" & i).CurrentRegion.Columns.Count). _
           Interior.ColorIndex = 37 '37=bleu
        End If
    Next
  
'Efface le contenu des cellules non colorées de la colonne K
'Dim cell As Range
'Set MyRange = Range("K3: K65000") 'Intersect(ActiveSheet.UsedRange.EntireRow, [K:K])
'For Each cell In MyRange
'If cell.Interior.ColorIndex = xlNone Then
    'cell.ClearContents
    'cell.Interior.ColorIndex = xlNone
'Else
'End If
'Next

'Colore en rouge les temps > 5mn
'Format texte pour la colonne K
Columns("K:K").Select
    Selection.NumberFormat = "@"
Range("K3:K65000").Select
For Each cell In Selection
'Si la valeur est supérieur à 5mn(au format texte) alors
If cell.Text > "0,00347222222222222" Then
'Colorie la couleur de la cellule en rouge
cell.Interior.ColorIndex = 3
End If
Next
'Retour au format heure de la colonne K
Columns("K:K").Select
    Selection.NumberFormat = "[$-F400]h:mm:ss AM/PM"

'Inscription "Durée entre deux tests" en entête de la colonne K
    Range("K2").Select
    ActiveCell.FormulaR1C1 = "Durée entre deux tests"
    
'Ajout des boutons filtre de donnée dans les entêtes
   Range("A2:K2").Select
    Selection.AutoFilter

'Concacène les colonnes A et B pour lier le comptage des références et numéro de série
Range("T3").Select
   Intersect(ActiveSheet.UsedRange.EntireRow, [T:T]).FormulaR1C1 = "=RC[-19]&RC[-18]"
   
'Place un x devant chaque occurence unique
Intersect(ActiveSheet.UsedRange.EntireRow, [U:U]).FormulaR1C1 = _
   "=IF(R[-1]C[-1]=RC[-1],"""",""x"")"
   
'Copie les colonnes T et U pour les coller en texte pour supprimer les formules
    Columns("T:U").Select
    Selection.Copy
    Columns("V:V").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("T:U").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft

'Compte le nombre de x
    Range("U2").ClearContents
    Range("T2").Select
    ActiveCell.FormulaR1C1 = "=COUNTIF(C[1],""x"")"
    
'Copie/colle le résultat du précédent calcul
    Range("T2").Select
    Selection.Copy
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
'Efface les colonnes T et U qui ont servies au calcul du nombre de tests
    Columns("T:U").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    
'Inscrit un x à côté des cellules rouges de la colonne K
'Dim cell As Range
Set MyRange = Range("K3: K65000") 'Intersect(ActiveSheet.UsedRange.EntireRow, [K:K])
For Each cell In MyRange
If cell.Interior.ColorIndex = 3 Then
    cell.Offset(0, 1) = "x"
Else
End If
Next

'Compte le nombre de x
    Range("M3").Select
    ActiveCell.FormulaR1C1 = "=COUNTIF(C[-1],""x"")"
    

'Copie/colle le résultat du précédent calcul
    Range("M3").Select
    Selection.Copy
    Range("C1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Columns("L:N").Select
    Selection.ClearContents
    
'Calcule le pourcentage de reprises "C1/A1"
    Range("D1").Select
     ActiveCell.FormulaR1C1 = "=RC[-1]/RC[-3]"
    
'Formatage cellule en pourcents
    Range("D1").Select
    Selection.NumberFormat = "0.00%"
    
'Compte le nombre de tests MAUVAIS
    Range("L1").Select
    ActiveCell.FormulaR1C1 = "=COUNTIF(C[-9],""MAUVAIS"")"

'Copie/colle le résultat du précédent calcul
    Range("L1").Select
    Selection.Copy
    Range("B1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        
'Efface la colonne L
    Columns("L").Select
    Application.CutCopyMode = False
    Selection.Delete Shift:=xlToLeft
    
'Ajout d'une ligne
    Rows("1:1").Select
    Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'Mise en forme des deux premières lignes + centrage cellules
    Rows("1:2").RowHeight = 30
    Rows("1:2").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    
'Inscription "Nombre de produits" en entête de la colonne A
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Nbre de produits"
    
'Inscription "Nombre de tests MAUVAIS" en entête de la colonne B
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "Nbre de tests MAUVAIS"
    
'Inscription "Nombre de reprises" en entête de la colonne C
    Range("C1").Select
    ActiveCell.FormulaR1C1 = "Nbre de reprises"
    
'Inscription "Pourcentage reprises" en entête de la colonne D
    Range("D1").Select
    ActiveCell.FormulaR1C1 = "Pourcentage reprises"
    
'Inscription "Nbre total de tests" en entête de la colonne F
    Range("F1").Select
    ActiveCell.FormulaR1C1 = "Nbre total de tests"

'Calcul du nombre total de test
    Range("F2").Select
    ActiveCell.FormulaR1C1 = "=RC[-5]+RC[-4]+RC[-3]"
    
'Colore les cellules A1 à K1 en gris
Range("A1:K1").Select
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = -0.149998474074526
        .PatternTintAndShade = 0
    End With
    
'Colore le texte de C2 en rouge
    Range("C2").Select
    With Selection.Font
        .color = -16776961
        .TintAndShade = 0
    End With
    
'Colore le texte de A2 en bleu
    Range("A2").Select
    With Selection.Font
        .color = -65536
        .TintAndShade = 0
    End With
    
'Colore le texte de D2 en bleu
    Range("D2").Select
    With Selection.Font
        .color = -65536
        .TintAndShade = 0
    End With
    
'Colore le texte de B2 en orange
    Range("B2").Select
    With Selection.Font
        .ThemeColor = xlThemeColorAccent6
        .TintAndShade = -0.249977111117893
    End With
Application.ScreenUpdating = True
    
End Sub

J'ai pas mal cherché sur internet et je ne trouve pas de solutions "universelles".

Peut-être incrémenter un compteur après chaque opération.

En tout cas merci pour ton aide Staple 1600

Staple1600 · 26 Avril 2014

Re : Barre de progression liée au défilement des lignes de code

Re

jp65
Merci pour la publication de ton code.
Mais joindre un fichier Excel avec le code VBA serait plus utile pour faire des tests sur nos PC.
Et accessoirement ton précédent message serait beaucoup moins long à lire

PS: Suggestion: tu pourrais alléger ton code de moults lignes en te passant des Select et autre Activate.
Un exemple de simplification ci-dessous

Code:

Sub VBA_WeightWatcher()
Dim entete
entete = Array("Début du test", "Nom de l'opérateur", "Numéro de série", "Référence du produit", "Référence du programme", "Rigidité AC entre groupes", "Fin du test", "TEST")
Range("A2:H2") = entete
End Sub

Trois lignes de codes au lieu de seize lignes

jp65 · 26 Avril 2014

Re : Barre de progression liée au défilement des lignes de code

Re Staple 1600

J'aime beaucoup le nom du Sub que tu donnes, il est tout a fait approprié à ma macro.
Il faut que je te dise que je ne suis qu'un débutant et que mon code est un aggloméra
de bout de codes fournis par de généreux forumistes, trouvés sur le net, et aussi générés
par l'enregistreur de macro excel (rien que le quadrillage du tableau prend 39 lignes).

Par contre et c'est déjà ça tout fonctionne.

Je joint un classeur excel avec la macro et un dossier avec des fichiers texte à traiter
(raccourci car je peux avoir plus de 1000 fichiers texte à traiter).

Je n'ai pas encore appliqué ton régime minceur car le but premier de ce post est d'avoir
une jolie barre de défilement.

Merci encore Staple 1600

Staple1600 · 26 Avril 2014

Re : Barre de progression liée au défilement des lignes de code

Re

jp65 à dit:
Je n'ai pas encore appliqué ton régime minceur car le but premier de ce post est d'avoir
une jolie barre de défilement.

Comme son nom, l'indique une suggestion ne fait que suggérer

Merci pour les fichiers.

Dés que j'ai un petit moment, je les regarde.

jp65 · 26 Avril 2014

Re : Barre de progression liée au défilement des lignes de code

OK

Merci et bonne soirée

JP

Staple1600 · 27 Avril 2014

Re : Barre de progression liée au défilement des lignes de code

Bonjour à tous

jp65
J'ai donc regardé tes PJ
Et comme je m'ennuyais en ce dimanche matin, j'ai pas pu résister à faire maigrir un peu ton code
(Je sais que ce n'est pas le but premier, mais cela pourra peut-être intéresser un ou deux paires d'yeux (dont la tienne)

Et pour ta jolie barre, j'espère que d'autres ici viendront à ta rescousse.

Un bout de régime

Code:

Dim dl As Integer
Dim entete
Application.ScreenUpdating = False
entete = Array("Début du test", "Nom de l'opérateur", "Numéro de série", "Référence du produit", "Référence du programme", "Rigidité AC entre groupes", "Fin du test", "TEST")
Range("A2:H2") = entete
Columns("A:M").EntireColumn.AutoFit
Rows("2:2").HorizontalAlignment = xlGeneral
Rows("2:2").VerticalAlignment = xlBottom
' Résultat feuille avec paramètres et résultats
 Set Feuil1 = Worksheets("Feuil1")

et un autre

Code:

' on prend le fichier suivant qui correspond au filtre
     f = Dir()
    Wend
    Set Feuil1 = Nothing
    End If
    
Dim vTa, vTb, z&
vTa = Array(4, 2, 8, 4, 6)
vTb = Array(1, 7, 2, 2, 4)
For z = LBound(vTa) To UBound(vTa)
Columns(vTa(z)).Cut
Columns(vTb(z)).Insert Shift:=xlToRight
Next
'Efface le contenu de G2
Range("G2:H2").ClearContents
'Insertion de d'une colonne avant E
Columns("E:E").Insert -4161, 0
'Application d'un filtre pour séparer "-" avec le résultat du diélectrique
    Range("D2").ClearContents
    Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
        :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
    Columns("D:D").Delete Shift:=xlToLeft
'Inscription "Diélectrique" en entête de la colonne D
Range("D2") = "Diélectrique"
'Insertion de deux colonnes avant H
Columns("H:I").Insert -4161, 0

jp65 · 27 Avril 2014

Re : Barre de progression liée au défilement des lignes de code

Bonjour le forum

Staple 1600
J'ai attaqué la cure d'amaigrissement que tu as initié.
Je vais bien sur appliquer les derniers éléments que tu m'a fourni.
Rien que le nombre de lignes économisées pour le déplacement des colonnes est impressionnant.

Merci encore pour ton attention.

Staple1600 · 27 Avril 2014

Re : Barre de progression liée au défilement des lignes de code

Bonsoir à tous

jp65
Prière de nous redire quels auront été les effets du régime en terme de :
Résultat final (est-il identique à la version originale de ta macro ?)
Rapidité d’exécution du code (plus rapide ou pas?)

Effectuez une recherche sur Excel Downloads...

Barre de progression liée au défilement des lignes de code

jp65

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

jp65

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

jp65

XLDnaute Junior

Pièces jointes

Staple1600

XLDnaute Barbatruc

jp65

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

jp65

XLDnaute Junior

Staple1600

XLDnaute Barbatruc

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums