VBA : Interruption de l'exécution d'une macro et reprise automatique après choix dans une liste

Bonjour,

Je dois exécuter une série de traitement sur un fichier.
Au début du processus l'utilisateur choisis et ouvre son fichier et ensuite, il doit faire un choix dans une liste déroulante.
Voici la méthode que j'utilise pour cette liste:

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14

With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="BIAC CDF ,BIAC USD ,RAW USD ,TMB CNF ,TMB USD " .IgnoreBlank = True .InCellDropdown = True .InputTitle = "Vos comptes" .ErrorTitle = "" .InputMessage = "Choisissez un compte en cliquant sur la flèche" .ErrorMessage = "" .ShowInput = True .ShowError = True End With

---

Je souhaite que la macro reprenne automatiquement son cours une fois que l'utilisateur a fait son choix.

Quelqu'un aurait-il une idée ?

Merci d'avance.

Henri

Bonjour,

tu vas devoir couper ta procédure en plusieurs morceaux pour ça.

peux-tu nous montrer l'intégralité de cette procédure ?


à titre d'exemple, une piste (possible suivant ce que contient ta procédure actuelle) :

1) première procédure, qui s'arrête à la création de la liste de validation, avec un message invitant l'utilisateur à faire son choix
2) seconde procédure, sur l'évènement Change de la feuille, pour vérifier que l'utilisateur a fait son choix. Si le choix est ok, appel de la procédure 3
3) la fin du traitement de ta procédure initiale.

Bonjour Joe.Levrai,

Merci pour la réponse.
En fouinant avant de poser la question, j'ai trouvé une procédure qui utilise effectivement cette fonction CHANGE, mais je ne sais pas comment l'utiliser.
Voici ce qui était proposé :

Code:

---

1 2 3 4 5 6 7 8

Private Sub Worksheet_Change(ByVal Target As Range)   If Not Application.Intersect(Target, Range("E1")) Is Nothing Then Call ListeDesPaiementsSuite End If   End Sub

---

J'ignore si le code est correct, mais je ne vois pas où le placer ni comment y faire appel.

Merci d'avance pour ta réponse.

Henri

PS: au besoin, je peux envoyer le code, pas de soucis.

C'est exactement ce type de procédure dont je parlais dans le point 2

oui il faut montrer ton code complet, le morceau que tu as montré ne présente pas certaines choses indispensables.

Désolé, mais il y a un problème avec l'ajout des fichiers sur Developpez.com.
Je peux te l'envoyer par mail ?

tu as juste à faire un copier coller de tes lignes de code dans un message, de la même façon que la procédure que avais montré dans ton message précédent

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70

Sub ListeDesPaiements() ' ' Mise en page de la liste des paiements issue de la liste des propositions de paiements de WinBooks. ' ' Ouverture du fichier Excel   On Error Resume Next ChDrive "X:" If Error Then ChDrive "C:" ChDir "C:\WinBooks\DataExcel" Else ChDir "X:\DataExcel" End If   nom = Application.GetOpenFilename("Nom fichier,*.XLS") If nom <> False Then Workbooks.Open nom Else Exit Sub End If On Error GoTo 0   ActiveSheet.Name = "Fournisseurs" ActiveSheet.Copy after:=ActiveSheet ActiveSheet.Name = "Banque"   Rows("1:4").Select Application.CutCopyMode = False Selection.Clear Columns("E:E").Select Selection.Delete Shift:=xlToLeft   ' Colonne reprenant le journal d'achat et le n° de document WinBooks Columns("H:I").Select Selection.Delete Shift:=xlToLeft   ' Déplacement des comptes en banque et BIC Columns("E:F").Select Selection.Cut Columns("H:H").Select Selection.Insert Shift:=xlToRight   With Selection.Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="BIAC CDF ,BIAC USD ,RAWUSD ,TMBCNF ,TMBUSD " .IgnoreBlank = True .InCellDropdown = True .InputTitle = "Vos comptes" .ErrorTitle = "" .InputMessage = "Choisissez un compte en cliquant sur la flèche" .ErrorMessage = "" .ShowInput = True .ShowError = True End With   Range("E1").Select Selection.Font.Bold = True   End Sub   Private Sub Worksheet_Change(ByVal Target As Range)   If Not Application.Intersect(Target, Range("E1")) Is Nothing Then Call ListeDesPaiementsSuite End If   End Sub

---

Et voici la suite

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348

Sub ListeDesPaiementsSuite()   Range("B5").Select ActiveCell.FormulaR1C1 = "Bénéficiaire" Range("H5").Select ActiveCell.FormulaR1C1 = "Banque"     ' Tranformation des EUR en USD et des ERO en EUR ' ==============================================   Columns("D:D").Select Selection.Replace What:="EUR", Replacement:="USD", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False Selection.Replace What:="ERO", Replacement:="EUR", LookAt:=xlPart, _ SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _ ReplaceFormat:=False   ' DEBUT DU CALCUL DE LA ZONE DE SOUS-TOTAL ' ========================================   Dim NbLigne As Integer Dim NbCol As Integer Dim ColCrt As Integer Dim NbMaxLigne As Integer   NbMaxLigne = 1   ' Nous connaissons la dernière colonne, calcul du plus grand nombre de ligne ' Cells(5, 256) parce que la 5ème ligne est celle des titres et donc on principe ' celle qui contient quelque chose dans toutes les colonnes occupées. ' 256 est le n° de la dernière colonne en format XLS qui est le format d'exportation ' des fichiers WinBooks. NbCol = Range(Cells(1, 1), Cells(5, 256).End(xlToLeft)).Columns.Count   ' Boucle : ' NbCol contient le nombre de colonne du tableau. ' On va donc parcourir colonne par colonne pour trouver la colonne qui contient le ' plus grand nombre de lignes. For ColCrt = 1 To NbCol   NbLigne = Range(Cells(1, ColCrt), Cells(65536, ColCrt).End(xlUp)).Rows.Count   If NbLigne > NbMaxLigne Then NbMaxLigne = NbLigne End If   Next ColCrt   ' FIN CALCUL DE LA ZONE DE SOUS-TOTAL ' ===================================   ' Marquage de la zone sur lequel le sous-total va s'effectuer   Dim i As Integer Dim LargCpt As Integer Dim LargBic As Integer   i = 6 LargCpt = 20 LargBic = 15   Range("A5").Select Range(Selection, ActiveCell.Offset(NbMaxLigne, NbCol)).Select   Selection.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(3), _ Replace:=True, PageBreaks:=False, SummaryBelowData:=True     Range("A6").Select   'Boucle sur les cellules de la colonne A 'On sort de la boucle si la cellule testée (Cells(i, 1)) est vide 'Cette boucle permet de vérifier s'il y a un ou plusieurs paiements par fournisseur et de placer le commentaire adéquat. ' - soit le commentaire provenant de WinBooks s'il n'y a qu'un paiement. ' - soit le commentaire "Pour détails du paiement voir mail" s'il y a plusieurs paiements   While Not IsEmpty(Cells(i, 1))   If Cells(i, 1) <> Cells(i + 1, 1) Then ActiveCell.Offset(0, 1).Select Range(Selection, ActiveCell.Offset(0, 13)).Select Selection.Copy ActiveCell.Offset(1, 0).Select ActiveSheet.Paste Application.CutCopyMode = False ActiveCell.Offset(1, -1).Select If Len(Cells(i, 5)) > LargCpt Then LargCpt = Len(Cells(i, 6)) End If If Len(Cells(i, 5)) > LargBic Then LargBic = Len(Cells(i, 7)) End If   i = i + 2   Else   Cells.Find(What:="Total", after:=ActiveCell, LookIn:=xlValues, LookAt:= _ xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _ False).Activate ActiveCell.Offset(-1, 1).Select Selection.Copy ActiveCell.Offset(1, 0).Select ActiveSheet.Paste Application.CutCopyMode = False ActiveCell.Offset(-1, 2).Select Range(Selection, ActiveCell.Offset(0, 10)).Select Selection.Copy ActiveCell.Offset(1, 0).Select ActiveSheet.Paste Application.CutCopyMode = False ActiveCell.Offset(1, -3).Select i = ActiveCell.Row   End If   Wend   ' On concatène les commentaires des paiements multiples Dim Comment As String Dim CelluleCrt As String   i = 6 Range("A6").Select   While Not IsEmpty(Cells(i, 1))   If Cells(i, 1) <> Cells(i + 1, 1) Then ActiveCell.Offset(2, 0).Select   Else   CelluleCrt = Cells(i, 1) Comment = "" While Cells(i, 1) = CelluleCrt Comment = Comment & Cells(i, 5) & " / " ActiveCell.Offset(1, 0).Select i = i + 1 Wend ActiveCell.Offset(0, 4).Select Comment = Left(Comment, Len(Comment) - 3) ActiveCell.FormulaR1C1 = Comment With Selection .HorizontalAlignment = xlGeneral .VerticalAlignment = xlTop .WrapText = True .Orientation = 0 .AddIndent = False .IndentLevel = 0 .ShrinkToFit = False .ReadingOrder = xlContext .MergeCells = False End With   ActiveCell.Offset(1, -4).Select   End If   i = ActiveCell.Row   Wend         ' On réduit la feuille aux seuls sous-totaux   ActiveSheet.Outline.ShowLevels RowLevels:=2   ' Effacement de la ligne du total général. Ce total général est le plus souvent faux car il totalise des devises différentes Cells.Find(What:="Total général", after:=ActiveCell, LookIn:=xlValues, LookAt:= _ xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:= _ False).Activate ActiveCell.EntireRow.Delete ActiveCell.EntireRow.Delete   ' Effacement de la colonne contenant les références qui n'est pas d'utilité. ActiveCell.EntireColumn.Delete     ' Elargissement des colonnes Columns("A:M").Select Columns("A:M").EntireColumn.AutoFit Columns("D:D").Select Selection.ColumnWidth = 42 Columns("F:F").Select Selection.ColumnWidth = LargBic + 3     ' DEBUT DU CALCUL DE LA ZONE D'IMPRESSION ' =======================================   NbMaxLigne = 1   ' Nous connaissons la dernière colonne, calcul du plus grand nombre de ligne ' Cells(5, 256) parce que la 5ème ligne est celle des titres et donc on principe ' celle qui contient quelque chose dans toutes les colonnes occupées. ' 256 est le n° de la dernière colonne en format XLS qui est le format d'exportation ' des fichiers WinBooks. NbCol = Range(Cells(1, 1), Cells(5, 256).End(xlToLeft)).Columns.Count   ' Boucle : ' NbCol contient le nombre de colonne du tableau. ' On va donc parcourir colonne par colonne pour trouver la colonne qui contient le ' plus grand nombre de lignes. For ColCrt = 1 To NbCol   NbLigne = Range(Cells(1, ColCrt), Cells(65536, ColCrt).End(xlUp)).Rows.Count   If NbLigne > NbMaxLigne Then NbMaxLigne = NbLigne End If   Next ColCrt   ' Définition de la plage de cellules à imprimer ActiveSheet.PageSetup.PrintArea = Range(Cells(5, 1), Cells(NbMaxLigne, NbCol)).Address   ' FIN CALCUL DE LA ZONE D'IMPRESSION ' ================================== ' ###################################################################################################   ' DEBUT DU FORMATAGE DE L'ENCADREMENT DES CELLULES ' ================================================ Range(Cells(5, 1), Cells(NbMaxLigne, NbCol)).Select Selection.Borders(xlDiagonalUp).LineStyle = xlNone With Selection.Borders(xlEdgeLeft) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.14996795556505 .Weight = xlThin End With With Selection.Borders(xlEdgeTop) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.14996795556505 .Weight = xlThin End With With Selection.Borders(xlEdgeBottom) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.14996795556505 .Weight = xlThin End With With Selection.Borders(xlEdgeRight) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.14996795556505 .Weight = xlThin End With With Selection.Borders(xlInsideVertical) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.14996795556505 .Weight = xlThin End With With Selection.Borders(xlInsideHorizontal) .LineStyle = xlContinuous .ThemeColor = 1 .TintAndShade = -0.14996795556505 .Weight = xlThin End With       ' DEBUT DE LA MISE EN PAGE DE L'IMPRESSION ' ========================================   On Error Resume Next ActiveSheet.PageSetup.LeftHeaderPicture.Filename = _ "X:\DataExcel\Logo Habari Kani.jpg" If Error Then ActiveSheet.PageSetup.LeftHeaderPicture.Filename = _ "d:\Dossiers\Dossiers Permanents\HABARI KANI - 404434\Logos\140925 - Logo Habari Kani - 207x41.png" End If   On Error Resume Next ActiveSheet.PageSetup.CenterFooterPicture.Filename = _ "X:\DataExcel\160222 - Libellés Date Noms Signature pour ordre de paiement.png" If Error Then ActiveSheet.PageSetup.CenterFooterPicture.Filename = _ "d:\Dossiers\DOCUMENTS GENERAUX\Sur mesure - originaux\Habari Kani\160222 - Libellés Date Noms Signature pour ordre de paiement.png" End If   Application.PrintCommunication = False With ActiveSheet.PageSetup .LeftHeader = "&G" & Chr(10) & "Route de Kinsevere PC5657" & Chr(10) & "Commune Annexe, LUBUMBASHI" .CenterHeader = "&""Arial,Gras""&13" & Range("D1").Value .RightHeader = "" .LeftFooter = "Imprimé le &D à &T" .CenterFooter = "&G" .RightFooter = " Page &P/&N" .LeftMargin = Application.InchesToPoints(0.15) .RightMargin = Application.InchesToPoints(0.13) .TopMargin = Application.InchesToPoints(0.8) .BottomMargin = Application.InchesToPoints(1) .HeaderMargin = Application.InchesToPoints(0.18) .FooterMargin = Application.InchesToPoints(0.13) .PrintHeadings = False .PrintGridlines = False ' .PrintComments = xlPrintNoComments .PrintComments = False .PrintQuality = 600 .CenterHorizontally = False .CenterVertically = False .Orientation = xlLandscape .Draft = False .PaperSize = xlPaperA4 .FirstPageNumber = xlAutomatic .Order = xlDownThenOver .BlackAndWhite = False .Zoom = False .FitToPagesWide = 1 .FitToPagesTall = 1000 .PrintErrors = xlPrintErrorsDisplayed .OddAndEvenPagesHeaderFooter = False .DifferentFirstPageHeaderFooter = False .ScaleWithDocHeaderFooter = True .AlignMarginsHeaderFooter = True .EvenPage.LeftHeader.Text = "" .EvenPage.CenterHeader.Text = "" .EvenPage.RightHeader.Text = "" .EvenPage.LeftFooter.Text = "" .EvenPage.CenterFooter.Text = "" .EvenPage.RightFooter.Text = "" .FirstPage.LeftHeader.Text = "" .FirstPage.CenterHeader.Text = "" .FirstPage.RightHeader.Text = "" .FirstPage.LeftFooter.Text = "" .FirstPage.CenterFooter.Text = "" .FirstPage.RightFooter.Text = "" .PrintTitleRows = "$5:$5" .PrintTitleColumns = "" End With Application.PrintCommunication = True   ' FIN DE LA MISE EN PAGE DE L'IMPRESSION ' ====================================== ' ##############################################################################################   ' Affichage de l'aperçu avant impression ActiveWindow.SelectedSheets.PrintPreview     End Sub

---

Bonjour,

il y a pas mal de ménage à faire dans tes procédures

déjà pour y voir plus claire : supprimer les sélection et le travail sur les objets actifs


voici un exemple de la première procédure, encore perfectible mais je m'arrête là pour pas que ça devienne trop compliqué (à tester bien sûr, j'ai écris ça à la volée) compare avec ce que tu avais auparavant afin de comprendre la mécanique qui évite de sélectionner les cellules et colonnes (ça ralenti énormément la macro)

Code:

---

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59

Sub ListeDesPaiements() Dim Sh As Worksheet Dim Nom ' Mise en page de la liste des paiements issue de la liste des propositions de paiements de WinBooks. ' ' Ouverture du fichier Excel   On Error Resume Next ChDrive "X:" If Error Then ChDrive "C:" ChDir "C:\WinBooks\DataExcel" Else ChDir "X:\DataExcel" End If   Nom = Application.GetOpenFilename("Nom fichier,*.XLS") If Nom <> False Then Set Wb = Workbooks.Open(Nom) Else Exit Sub On Error GoTo 0   Application.ScreenUpdating = False   Set Sh = Wb.ActiveSheet Sh.Name = "Fournisseurs" Sh.Copy after:=Sh Set Sh = Wb.ActiveSheet   With Sh .Name = "Banque" .Rows("1:4").Clear .Columns("E:E").Delete Shift:=xlToLeft .Columns("H:I").Delete Shift:=xlToLeft .Columns("E:F").Cut   With UsedRange.Columns("H:H")   .Insert Shift:=xlToRight   With .Validation .Delete .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _ xlBetween, Formula1:="BIAC CDF ,BIAC USD ,RAWUSD ,TMBCNF ,TMBUSD " .IgnoreBlank = True .InCellDropdown = True .InputTitle = "Vos comptes" .ErrorTitle = "" .InputMessage = "Choisissez un compte en cliquant sur la flèche" .ErrorMessage = "" .ShowInput = True .ShowError = True End With End With   .Range("E1").Font.Bold = True End With   Application.ScreenUpdating = True   End Sub

---

Tente d'appliquer ça sur ta dernière procédure

reviens avec les modifications et si ça bug, les lignes incriminées (et les messages d'erreur)



Ensuite seulement on aura une base stable pour continuer

Bonjour Joe,

Merci encore pour la peine que tu t'es donnée.
La solution qui consistait à réécrire mon code présentait deux inconvénients.
1) j'avais une contrainte de temps.
2) J'ai appris le VBA en picorant des solutions sur le net. Je n'ai donc pas les bases nécessaires à faire du code bien structuré.
Quand je dois écrire quelque chose, je tape ma question dans Google, j'essaie, ça fonctionne, j'applique.
Ceci dit, je m'inscrirai à un cours de VBA dès mon retour en Europe, car d'un petit module de temps à autre, je passe à une production régulière, il est donc temps de passer de l'amateurisme au professionnalisme.

Bonne journée et encore merci.

Henri