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
| Sub PrepaConclusion()
Dim NbCol As Long
Dim NbLign As Long
Dim Hauteur As Double
Dim Largeur As Double
Dim Adres As String
Dim i As Long
Dim n As Long
Dim IntIdCol1 As Long
Dim IntIdCol2 As Long
Dim RCell As Range
Dim sht As Worksheet
Dim RefCellEnCours As Range
Dim NomCombo() As String
Dim NomCmbx As String
Dim arret As Long ' msg de demarrage
Dim oldStatusBar
' gestion des erreurs
On Error GoTo GestionDesErreurs:
arret = MsgBox("Confirmer le démarrage, Lancement la préparation conclusion (ajout des colonnes listBox ? et effacement des listbox) ", vbYesNo + vbDefaultButton2, "CONFIRMATION")
' 6= oui, 7 = non
If arret = 6 Then
Else
Exit Sub
End If
' désactiver l'affichage pendant l'exécution d'une macro VBA pour en accélérer l'exécution
Stop 'repasser en false
Application.ScreenUpdating = True
' accélération traitement
Application.Calculation = xlCalculationManual
' message d'attente
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "C'est pas fini..."
' sablier
Application.Cursor = xlWait
If ActiveSheet.FilterMode Then
ActiveSheet.ShowAllData
End If
Call LesParametres
Sheets(Nom_Feuille_Samples).Select
ActiveSheet.Range("A1").CurrentRegion.Select
Set sht = ThisWorkbook.Worksheets(Nom_Feuille_Samples)
sht.DropDowns.Select
sht.DropDowns.Delete
ActiveSheet.Range("A1").CurrentRegion.Select
' insertion des colonnes
NbCol = Sheets(Nom_Feuille_Samples).UsedRange.Columns.Count
NbLign = Selection.Rows.Count
For i = 1 To 5
Cells(1, NbCol + i).Value = NomColFinSample(i)
Next i
Call LesParametres 'pour mémoriser positions
Sheets(Nom_Feuille_Samples).Select
' largeur colonne et ligne fixé
Hauteur = Worksheets(Nom_Feuille_Samples).StandardHeight
Worksheets(Nom_Feuille_Samples).Rows.RowHeight = Hauteur
Cells(1, NbCol + 1).RowHeight = 20
Largeur = Worksheets(Nom_Feuille_Samples).StandardWidth
Worksheets(Nom_Feuille_Samples).Columns.ColumnWidth = 30
'Positionnement cellule en haut à gauche
Adres = ActiveCell.Address
Range("A1").Select
ActiveWindow.SmallScroll Down:=Range(Adres).Row - 1
ActiveWindow.SmallScroll ToRight:=Range(Adres).Column - 1
Range(Adres).Offset(1, 1).Select
' ajout des listbox v============================================================================
'LancementBarreProgress() µµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµ
' Initialize variables barre de progression.
Compteur = 1
RowMax = NbLign
'Création et formulation des listbox
ReDim Preserve NomCombo(NbLign + 1)
For i = 2 To NbLign '=============================================== For i = 2 To NbLign ==========================================================
Set RefCellEnCours = Cells(i, NbCol + 1)
RefCellEnCours.Select
' ActiveCell.Offset(0, 1).Range("A1").Select
NomCmbx = "Combo" & (i - 1)
With RefCellEnCours
sht.DropDowns.Add(.Left, .Top, .Width, .Height).Name = NomCmbx
End With
sht.DropDowns(NomCmbx).Select
'Stop
With Selection 'Modif 07/07
.ListFillRange = Nom_PlageIndexAlgo
.DropDownLines = 8
End With
Set RefCellEnCours = Cells((i), NbCol + 2)
Cells((i), NbCol + 3).Select
ActiveCell.FormulaR1C1 = "=INDEX(" & Nom_PlageIndexAlgo & ",RC[-1])" 'ici on colle formule pour obtenir nomLeCas
sht.DropDowns(NomCmbx).Select 'selection de l'index commence à 1 combo(0) = 1
With Selection
.ListFillRange = Nom_PlageIndexAlgo
.LinkedCell = RefCellEnCours.Address
.DropDownLines = 8
.Name = NomCmbx
End With
' Appel subroutine barre de progression µµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµ
' Update the percentage completed.
PctDone = Compteur * 100 / RowMax
' Call subroutine qui met à jour la progress bar.
UpdateProgressBar PctDone
Compteur = Compteur + 1
Next i '=============================================== For i = 2 To NbLign ==========================================================
Call MiseEnFormeListBox
'libération mémoire barre de progression µµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµµ
Unload UF_Barre
Sheets("Outils").Select
' activer l'affichage pendant l'exécution d'une macro VBA pour en accélérer l'exécution
Application.ScreenUpdating = True
' Fin accélération traitement
Application.Calculation = xlCalculationAutomatic
' message d'attente
Application.DisplayStatusBar = False
Application.DisplayStatusBar = oldStatusBar
Application.StatusBar = ""
' sablier
Application.Cursor = xlNormal
MsgBox ("Remplir les choix <LE CAS produits> des listes déroulantes avant de lancer l'étape suivante (possible aussi de travailler à partir de <index> mais ne pas faire de copier coller dans la colonne <LE CAS produits>. " _
& Chr(10) & "C'est Terminé !" & Chr(10) & " étape suivante : 7 LAncer algorithme " & Chr(10) & "En cours de developpement 6.Interprétation des listbox semi automatique Trouver les Cas Produits ")
Exit Sub 'evite l'execution des gestions d'erreurs si pas d'erreurs
GestionDesErreurs:
MsgBox "Erreur: " & Err.Description & Chr(13) & " Erreur : PrepaConclusion, "
End Sub |
VBA Excel erreur dépassement de capacité
Répondre avec citation
Partager