Bonjour,
j'ai une macro qui fait appel à une userform contenant une barre de progression.
Jusque la aucun probleme,ma macro marche comme je le souhaite;de meme que le userform s'affiche au moment voulu et disparait à la fin de la macro,impeccable.
Cependant pendant l'exécution de ma macro ma barre de progression(à l'interieur du usf) se remplit automatiquement or je souhaite qu'elle progresse en fonction de l'exécution de la macro.
C'est la que je suis bloqué,je ne sais vraiment comment y arriver,je penche la dessus depuis plusieurs jours maintenant.
Merci de m'aider s'il vous plait
voici mon code
j'ai une macro qui fait appel à une userform contenant une barre de progression.
Jusque la aucun probleme,ma macro marche comme je le souhaite;de meme que le userform s'affiche au moment voulu et disparait à la fin de la macro,impeccable.
Cependant pendant l'exécution de ma macro ma barre de progression(à l'interieur du usf) se remplit automatiquement or je souhaite qu'elle progresse en fonction de l'exécution de la macro.
C'est la que je suis bloqué,je ne sais vraiment comment y arriver,je penche la dessus depuis plusieurs jours maintenant.
Merci de m'aider s'il vous plait
voici mon code
Code:
Option Explicit
Dim ProgressIndicator As UserForm1
Sub Rassembler()
'Déclarations, opérations préliminaires...
Dim Counter As Integer
Dim RowMax As Integer, ColMax As Integer
Dim r As Integer, c As Integer
Dim PctDone As Single
Application.Calculation = xlManual
FiltrerDateRassembler
Application.ScreenUpdating = False
' Crée une copie du forme dans une variable
Set ProgressIndicator = New UserForm1
' Affiche Barreprogression dans état modeless
ProgressIndicator.Show vbModeless
If TypeName(ActiveSheet) <> "Worksheet" Then
Unload ProgressIndicator
Exit Sub
End If
Counter = 1
RowMax = 650
ColMax = 50
For r = 1 To RowMax
For c = 1 To ColMax
Counter = Counter + 1
Next c
PctDone = Counter / (RowMax * ColMax)
Call UpdateProgress(PctDone)
Next r
'Feuilles à traiter
Const cF = "JAL_AN/Gestion_Créancier/Gestion_Caisse/Gestion_Banque/JAL_OD"
'Ligne des en-têtes de chaque feuille à traiter
Const cFligneDebut = "11/10/9/11/11"
'Noms des champs à copier
Const cChamps = "N°compte gle/Mois/Date/Libellé/Débit/Crédit"
'Le & remplace ' as long', le $ remplace ' as string'
Dim i&, j&, DebLig&, Finlig&, NumCol, rep&
Dim F, FligneDebut, Champs, NomF$, Sh As Worksheet
Dim rgTitre As Range, rgAcopier As Range, rgBase As Range, rgIci As Range
'Split transforme une chaine de caractères en un tableau de mots à une dimension
'le séparateur de mots est le caractère /
'indice inf du tableau résultant est toujours 0 (jamais 1)
F = Split(cF, "/") 'tableau des noms des feuilles à traiter
FligneDebut = Split(cFligneDebut, "/") 'Tableau des n° ligne des en-têtes
Champs = Split(cChamps, "/") 'Tableau des champs à copier
'effacer précédent traitement
Sheets("TCD").Activate
ActiveSheet.Unprotect "MDP"
Range("A2:H" & Rows.Count).Clear
Application.ScreenUpdating = False
'lbound(tablo,2) retourne le plus petit indice de la deuxième dimension de tablo
'ubound(tablo,1) retourne le plus grand indice de la première dimension de tablo
'ex: si DIM tablo( 0 to 4, 10 to 29) alors
'lbound(tablo,1)=0, ubound(tablo,1)=4, lbound(tablo,2)=10, ubound(tablo,2)=29
'si on traite la première dimension du tableau, on peut omettre ,1
'lbound(tablo)=0, ubound(tablo)=4
'Quand on ne connait pas à l'avance les bornes des indices d'un tableau, c'est pratique.
'Quand on ne sait plus si SPLIT donne des tableaux à base 0 ou 1, lbound et ubound
'permette de contourner cet oubli.
For i = LBound(F) To UBound(F)
'Boucle sur les noms de feuilles à traiter
NomF = F(i): Set Sh = Sheets(NomF)
'on ôte le filtres automatique
If Sh.AutoFilterMode Then Sh.AutoFilterMode = False
'n° ligne des en-têtes
DebLig = FligneDebut(i)
'recherche de la dernière ligne à copier
Finlig = Sh.Range("b" & Rows.Count).End(xlUp).Row
If Finlig > DebLig Then
'il y a effectivement des données à copier
'Définir la cellule où copier les champs - on se base sur la colonne C des dates
Set rgBase = Range("c" & Rows.Count).End(xlUp).Offset(1, -2)
'définir la zone d'en-tête
Set rgTitre = Sh.Range(Sh.Cells(DebLig, "a"), Sh.Cells(DebLig, _
"a").End(xlToRight))
'rétablir le filtre mais en affichant tout
Sh.Unprotect "MDP"
rgTitre.AutoFilter
For j = LBound(Champs) To UBound(Champs)
'boucle sur les champs à copier
'on error resume next permet de continuer l'exécution si le champ cherché
'ne se trouve pas dans la ligne des titres
NumCol = 0
'rechercher le numéro de colonne du champ à copier dans la ligne d'en-têtes
On Error Resume Next
NumCol = Application.WorksheetFunction.Match(Champs(j), rgTitre, 0)
If NumCol > 0 Then
'le champ a été trouvé (donc son numéro), on copie les données
Set rgAcopier = Sh.Range(Sh.Cells(DebLig + 1, NumCol), Sh.Cells(Finlig, _
NumCol))
Set rgIci = rgBase.Offset(, j)
rgAcopier.Copy
rgIci.PasteSpecial xlPasteValues
rgIci.PasteSpecial xlPasteFormats
ElseIf NomF = "Gestion_Créancier" And Champs(j) = "Débit" Then
' le champ à copier est inconnu
'==> VERRUE 1 : feuille = "Gestion_Créancier" et Champs = "Débit"
'chercher le champ "Mtant TTC" (on suppose qu'il existe toujours)
'pas de gestion du cas où il serait inexistant!
NumCol = Application.WorksheetFunction.Match("Mtant TTC", rgTitre, 0)
Set rgAcopier = Sh.Range(Sh.Cells(DebLig + 1, NumCol), Sh.Cells(Finlig, _
NumCol))
Set rgIci = rgBase.Offset(, j)
rgAcopier.Copy
rgIci.PasteSpecial xlPasteValues
rgIci.PasteSpecial xlPasteFormats
'chercher le champ "Dt TVA" (on suppose qu'il existe toujours)
'pas de gestion du cas où il serait inexistant!
NumCol = Application.WorksheetFunction.Match("Dt TVA", rgTitre, 0)
Set rgAcopier = Sh.Range(Sh.Cells(DebLig + 1, NumCol), Sh.Cells(Finlig, _
NumCol))
Set rgIci = rgBase.Offset(, j)
rgAcopier.Copy
rgIci.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlPasteSpecialOperationSubtract
ElseIf NomF = "Gestion_Créancier" And Champs(j) = "Crédit" Then
'' le champ à copier est inconnu
'==> VERRUE 2 : feuille = "Gestion_Créancier" et Champs = "Crédit"
'chercher le champ "Mtant TTC" (on suppose qu'il existe toujours)
'pas de gestion du cas où il serait inexistant!
'on ne fait rien càd on laisse la cellule à vide
Else
'le champ à recopier n'existe pas et ne fait pas l'objet d'une VERRUE
'on y met le texte en rouge <Champs> PAS TROUVÉ
Set rgIci = rgBase.Offset(, j).Resize(Finlig - DebLig)
rgIci.Value = "Champ <" & Champs(j) & "> PAS TROUVÉ"
rgIci.Font.Bold = True
rgIci.Font.Color = RGB(255, 0, 0)
End If
Next j
Set rgIci = rgBase.Offset(, j).Resize(Finlig - DebLig)
rgIci = NomF
End If
Next i
Range("a1").CurrentRegionShrinkToFit = False
Range("a1").CurrentRegion.Borders.LineStyle = xlContinuous
Range("a1").CurrentRegion.FormatConditions.Delete
Range("a1").Resize(, UBound(Champs) - LBound(Champs) + 1).Value = Champs
Range("a1").Offset(, UBound(Champs) - LBound(Champs) + 1) = "Code JAL"
'déplacement de la dernière colonne de TCD (Code JAL) avant la colonne B
Columns(UBound(Champs) - LBound(Champs) + 2).Cut
Columns("B:B").Insert Shift:=xlToRight
Range("a1").CurrentRegion.EntireColumn.AutoFit
Range("a1").CurrentRegion.Rows(1).Interior.Color = RGB(200, 200, 200)
'VERRUE: Suppression des lignes où N°compte gle est à vide
Set rgAcopier = Nothing
On Error Resume Next
Set rgAcopier = _
Range("a1").CurrentRegion.Offset(1).Columns(1).SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
If Not rgAcopier Is Nothing Then
'il y a des cellules vide, on supprime leur ligne
rgAcopier.EntireRow.Delete
End If
'Création COLONNE Intitulé
Range("H1") = "Intitulé"
Range("H2").Select
ActiveCell.FormulaR1C1 = "=IF(ISBLANK(RC[-7]),"""",CONCATENATE(RC[-7],"" - "",(LOOKUP(RC[-7],COMPTES,INTITULE_COMPTES))))"
Selection.Copy
Range("H3:H" & ActiveSheet.UsedRange.Rows.Count).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("H1").CurrentRegion.EntireColumn.AutoFit
'RANGER par N° de compte du plus petit au plus grand
Range("A1:J1").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("TCD").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("TCD").AutoFilter.Sort.SortFields.Add Key:=Range( _
"D1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("TCD").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Création COLONNE Solde Débit.
Range("I1") = "Solde Débit."
Range("I2").Select
ActiveCell.FormulaR1C1 = _
"=IF(SUMPRODUCT((R2C[-8]:RC[-8]=RC[-8])*(R2C[-3]:RC[-3]-R2C[-2]:RC[-2]))>0,SUMPRODUCT((R2C[-8]:RC[-8]=RC[-8])*(R2C[-3]:RC[-3]-R2C[-2]:RC[-2])),0)"
Selection.Copy
Range("I2:I" & ActiveSheet.UsedRange.Rows.Count).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("I1").CurrentRegion.EntireColumn.AutoFit
'Création COLONNE Solde Crédit.
Range("J1") = "Solde Crédit."
Range("J2").Select
ActiveCell.FormulaR1C1 = _
"=IF(SUMPRODUCT((R2C[-9]:RC[-9]=RC[-9])*(R2C[-4]:RC[-4]-R2C[-3]:RC[-3]))<0,SUMPRODUCT((R2C[-9]:RC[-9]=RC[-9])*(R2C[-3]:RC[-3]-R2C[-4]:RC[-4])),0)"
Selection.Copy
Range("J2:J" & ActiveSheet.UsedRange.Rows.Count).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("J1").CurrentRegion.EntireColumn.AutoFit
Range("A1:J1").Select
Selection.AutoFilter
Range("a1").Select
Application.ScreenUpdating = True
ActiveSheet.Protect "MDP"
For i = LBound(F) To UBound(F)
'Boucle sur les noms de feuilles à traiter
NomF = F(i): Set Sh = Sheets(NomF)
'On reprotege les feuilles déprotégées
Sh.Protect "MDP"
Next
Unload ProgressIndicator
Set ProgressIndicator = Nothing
Sheets("Grand_Livre").Select
Application.ScreenUpdating = True
Application.Calculation = xlAutomatic
End Sub
Code:
Sub UpdateProgress(pct)
With ProgressIndicator
.FrameProgress.Caption = Format(pct, "0%")
.LabelProgress.Width = pct * (.FrameProgress _
.Width - 10)
End With
' L'instruction DoEvents est responsable fde la mise à jour de l'Userform
DoEvents
End Sub
.
