Aide pour achever cette macro

**leaxel** · 24/08/2017, 16h56

Bonjour,
j'ai cette macro , elle fonctionne bien sauf qu'aujourd'hui je ne fais que le ligne A1 de la colonne 1.
j' aimerais faire toutes les lignes contenant un mot de la colonne 1.
Pouvez vous m'aider ?

Voici la macro :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub Initialisation()
    Application.ScreenUpdating = False
    Sheets("Feuil1").Select
    Range("B1").Select
    PartieTraitee = Range("A1").Value
    PartieFille = ""
    NbrCarMotEntier = Len(PartieTraitee)
    DateDebut = Date
    TempsDebut = Time
 
    Select Case NbrCarMotEntier
        Case Is < 3
            Exit Sub
        Case Is <= 12
            Traitement
        Case Is > 12
            MsgBox "maxi 12 caractères"
     End Select
End Sub
 
Sub Traitement()
            Cpt2Car = 0
            Cpt3Car = 0
            Cpt4Car = 0
            Cpt5Car = 0
            Cpt6Car = 0
            Cpt7Car = 0
            Cpt8Car = 0
            Cpt9Car = 0
            Cpt10Car = 0
            Cpt11Car = 0
            Cpt12Car = 0
    Select Case NbrCarMotEntier
        Case 2
            GoTo Permutation2Caracteres
        Case 3
            GoTo Permutation3Caracteres
        Case 4
            GoTo Permutation4Caracteres
        Case 5
            GoTo Permutation5Caracteres
        Case 6
            GoTo Permutation6Caracteres
        Case 7
            GoTo Permutation7Caracteres
        Case 8
            GoTo Permutation8Caracteres
        Case 9
            GoTo Permutation9Caracteres
        Case 10
            GoTo Permutation10Caracteres
        Case 11
            GoTo Permutation11Caracteres
        Case 12
            GoTo Permutation12Caracteres
    End Select
 
Permutation12Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 12
    If NbrCarMotEntier = 12 And Cpt12Car = 12 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt12Car = 12 Then
        AffichageFinal
        Exit Sub
    End If
    Permutation
    Origine = PartieTraitee
    Cpt12Car = Cpt12Car + 1
 
Permutation11Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 11
    If NbrCarMotEntier = 11 And Cpt11Car = 11 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt11Car = 11 Then
        Cpt11Car = 0
        GoTo Permutation12Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt11Car = Cpt11Car + 1
 
Permutation10Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 10
    Permutation
    Origine = PartieTraitee
    Cpt10Car = Cpt10Car + 1
    If NbrCarMotEntier = 10 And Cpt10Car = 10 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt10Car = 10 Then
        Cpt10Car = 0
        GoTo Permutation11Caracteres
    End If
 
Permutation9Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 9
    If NbrCarMotEntier = 9 And Cpt9Car = 9 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt9Car = 9 Then
        Cpt9Car = 0
        GoTo Permutation10Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt9Car = Cpt9Car + 1
 
 
Permutation8Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 8
    If NbrCarMotEntier = 8 And Cpt8Car = 8 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt8Car = 8 Then
        Cpt8Car = 0
        GoTo Permutation9Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt8Car = Cpt8Car + 1
 
Permutation7Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 7
    If NbrCarMotEntier = 7 And Cpt7Car = 7 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt7Car = 7 Then
        Cpt7Car = 0
        GoTo Permutation8Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt7Car = Cpt7Car + 1
 
Permutation6Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 6
    If NbrCarMotEntier = 6 And Cpt6Car = 6 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt6Car = 6 Then
        Cpt6Car = 0
        GoTo Permutation7Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt6Car = Cpt6Car + 1
 
Permutation5Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 5
    If NbrCarMotEntier = 5 And Cpt5Car = 5 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt5Car = 5 Then
        Cpt5Car = 0
        GoTo Permutation6Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt5Car = Cpt5Car + 1
 
Permutation4Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 4
    If NbrCarMotEntier = 4 And Cpt4Car = 4 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt4Car = 4 Then
        Cpt4Car = 0
        GoTo Permutation5Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt4Car = Cpt4Car + 1
 
Permutation3Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 3
    If NbrCarMotEntier = 3 And Cpt3Car = 3 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt3Car = 3 Then
        Cpt3Car = 0
        GoTo Permutation4Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt3Car = Cpt3Car + 1
 
Permutation2Caracteres:
    DeuxiemeCar = Mid(PartieTraitee, 2, 1)
    PremierCar = Left(PartieTraitee, 1)
    Reste = Mid(PartieTraitee, 3, NbrCarMotEntier - 1)
    PartieTraitee = DeuxiemeCar & PremierCar & Reste
    Affichage
    Cpt2Car = Cpt2Car + 1
    If Cpt2Car = 2 Then
        Cpt2Car = 0
        GoTo Permutation3Caracteres
    Else
        GoTo Permutation2Caracteres
    End If
End Sub
 
Sub Permutation()
    PartieTraitee = Left(Origine, NbrCarPartieTraitee)
    PartieMere = Mid(PartieTraitee, 2, NbrCarPartieTraitee - 1)
    Rejeton = Left(PartieTraitee, 1)
    If NbrCarMotEntier = NbrCarPartieTraitee Then
        PartieFille = ""
    Else
        PartieFille = Right(Origine, NbrCarMotEntier - NbrCarPartieTraitee)
    End If
    PartieTraitee = PartieMere & Rejeton & PartieFille
End Sub
 
Sub Affichage()
    ActiveCell.Value = PartieTraitee
    PositionCellule = ActiveCell.Address(RowAbsolute:=False)
    LigneRecherchée = ActiveCell.Row
    If LigneRecherchée = 1048576 Then
        PositionCellule = ActiveCell.Address(ColumnAbsolute:=False)
        'colonneRecherchée = Left(PositionCellule, 2)
        colonneRecherchée = ActiveCell.Column
        If colonneRecherchée = 16384 Then
            Sheets.Add
            Range("B1").Select
        Else
            ActiveCell.Offset(-1048575, 1).Range("B1").Select
            Application.ScreenUpdating = True
            Application.ScreenUpdating = False
        End If
    Else
        ActiveCell.Offset(0, 0).Range("B1").Select
    End If
End Sub
 
 
 
Sub AffichageFinal()
    Application.ScreenUpdating = True
    Trier
    DateFin = Date
    TempsFin = Time
    MsgBox "la recherche a commencé le " & DateDebut & " à " & TempsDebut & " et fini le " & DateFin & " à " & TempsFin
End Sub
 
Sub Trier()
    For i = 1 To 16384
        Columns(i).Select
        If IsEmpty(ActiveCell.Offset(1, 0)) Then Exit Sub
        Selection.Sort Key1:=ActiveCell.Offset(1, 0), Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Next i
End Sub

**mjpmjp** · 24/08/2017, 19h07

bonjour,
pour faire fonctionner ton code sur xl2010
j'ai déclaré les variables

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Dim PartieMere As String
Dim PartieFille As String
Dim Rejeton As String
Dim PartieTraitee As String
Dim Origine As String
Dim DeuxiemeCar As String
Dim PremierCar As String
Dim Reste As String
 
Dim DateDebut As Variant
Dim TempsDebut As Variant
Dim DateFin As Variant
Dim TempsFin As Variant
 
Dim PositionCellule As Variant
Dim LigneRecherchée As Variant
 
Dim NbrCarMotEntier As Integer
Dim NbrCarPartieTraitee As Integer
Dim Cpt2Car As Integer
Dim Cpt3Car As Integer
Dim Cpt4Car As Integer
Dim Cpt5Car As Integer
Dim Cpt6Car As Integer
Dim Cpt7Car As Integer
Dim Cpt8Car As Integer
Dim Cpt9Car As Integer
Dim Cpt10Car As Integer
Dim Cpt11Car As Integer
Dim Cpt12Car As Integer
 
Dim ColonLimit As Integer

j'ai ajouté cette variable

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Dim ColonLimit As Integer

et modifié cette sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub Initialisation()
    Application.ScreenUpdating = False
    Sheets("Feuil1").Select
    Range("B1").Select
    PartieTraitee = Range("A1").Value
    PartieFille = ""
    NbrCarMotEntier = Len(PartieTraitee)
    DateDebut = Date
    TempsDebut = Time
 
 '----- MODIF JP ---------
    ColonLimit = Me.Columns.Count - 1
    MsgBox ColonLimit
 '------------------------
 
    Select Case NbrCarMotEntier
        Case Is < 3
            Exit Sub
        Case Is <= 12
            Traitement
        Case Is > 12
            MsgBox "maxi 12 caractères"
     End Select
End Sub

et cette sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 
Sub Affichage()
 '----- MODIF JP ---------
    ActiveCell.Value = PartieTraitee
    colonneRecherchée = ActiveCell.Column
    'If colonneRecherchée = 16384 Then
    If colonneRecherchée = ColonLimit Then
        Sheets.Add After:=Sheets(Sheets.Count)
        DoEvents
    Else
        ActiveCell.Offset(0, 0).Range("B1").Select
    End If
 '------------------------
    'PositionCellule = ActiveCell.Address(RowAbsolute:=False)
    'LigneRecherchée = ActiveCell.Row
    'If LigneRecherchée = 1048576 Then
    '    PositionCellule = ActiveCell.Address(ColumnAbsolute:=False)
    '        ActiveCell.Offset(-1048575, 1).Range("B1").Select
    '        Application.ScreenUpdating = True
    '        Application.ScreenUpdating = False
    '    End If
End Sub

résultat (avec en A1 : 4278361509 ) :

j'ai arrêté à 120 onglet ....

j'ai transposé les 7 premiers en une seule colonne....pas de doubles ... 115000 lignes

@+JP

**mjpmjp** · 24/08/2017, 19h48

bonjour,
pour ce qui est ton problème :

j' aimerais faire toutes les lignes contenant un mot de la colonne 1.

j'ai donc ajouté des nouvelles déclarations

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
 
 '----- MODIF JP ---------
Dim ColonLimit As Integer
Dim LigneFin As Integer
Dim LigneSel As Integer
Dim SheetNum As Integer
 '------------------------

et pour l'instant modifié cette sub

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub Initialisation()
 '----- MODIF JP ---------
    SheetNum = 1
    Sheets(1).Select
    Application.ScreenUpdating = False
    ColonLimit = Me.Columns.Count - 1 ': MsgBox ColonLimit
    LigneFin = Range("A" & Rows.Count).End(xlUp).Row
    'boucle sur colon A
    For LigneSel = 1 To LigneFin
        If Sheets(1).Range("A" & LigneSel).Value <> "" Then
           Sheets(1).Range("B" & LigneSel).Select
           PartieTraitee = Sheets(1).Range("A" & LigneSel).Value
           PartieFille = ""
           NbrCarMotEntier = Len(PartieTraitee)
           DateDebut = Date
           TempsDebut = Time
 
           Select Case NbrCarMotEntier
               Case Is < 3
                   Exit Sub
               Case Is <= 12
                   Traitement
               Case Is > 12
                   MsgBox "maxi 12 caractères"
            End Select
        End If
    Next LigneSel
 '------------------------
End Sub

il va y avoir d'autres modif , car , pour la première ligne des onglets ont été créés ...
il va donc falloir les gérer --> existe oui/non écrire dans onglet sheets(SheetNum)...

@+JP

**mjpmjp** · 24/08/2017, 19h54

re,
j'avais zapé cette modif

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
 
 
Sub Trier()
    For i = 1 To ColonLimit '16384 <-- MODIF ---
        Columns(i).Select
        If IsEmpty(ActiveCell.Offset(1, 0)) Then Exit Sub
        Selection.Sort Key1:=ActiveCell.Offset(1, 0), Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Next i
End Sub

**mjpmjp** · 24/08/2017, 20h05

bonjour,
voila donc la version qui fonctionne

avec :
A1 = 52641793
A2 = 63987215

Sub Initialisation()

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub Initialisation()
 '----- MODIF JP ---------
    Application.ScreenUpdating = False
    ColonLimit = Me.Columns.Count - 1 ': MsgBox ColonLimit
    LigneFin = Range("A" & Rows.Count).End(xlUp).Row
    'boucle sur colon A
    For LigneSel = 1 To LigneFin
        Application.ScreenUpdating = True
        Application.ScreenUpdating = False
        SheetNum = 1
        Sheets(1).Select
        If Sheets(1).Range("A" & LigneSel).Value <> "" Then
           Sheets(1).Range("B" & LigneSel).Select
           PartieTraitee = Sheets(1).Range("A" & LigneSel).Value
           PartieFille = ""
           NbrCarMotEntier = Len(PartieTraitee)
           DateDebut = Date
           TempsDebut = Time
 
           Select Case NbrCarMotEntier
               Case Is < 3
                   Exit Sub
               Case Is <= 12
                   Traitement
               Case Is > 12
                   MsgBox "maxi 12 caractères"
            End Select
        End If
    Next LigneSel
    Sheets(1).Select
    Sheets(1).Cells(1, 1).Select
    Application.ScreenUpdating = True
 '------------------------
End Sub

Sub Affichage()

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Sub Affichage()
 '----- MODIF JP ---------
    ActiveCell.Value = PartieTraitee
    colonneRecherchée = ActiveCell.Column
    If colonneRecherchée = ColonLimit Then
        SheetNum = SheetNum + 1
        colonneRecherchée = 1
        If LigneSel = 1 Then
            Sheets.Add After:=Sheets(Sheets.Count)
            DoEvents
        Else
            If SheetNum < Sheets.Count Or SheetNum = Sheets.Count Then
                Sheets(SheetNum).Select
                Sheets(SheetNum).Cells(LigneSel, colonneRecherchée).Select
            Else
                Sheets.Add After:=Sheets(Sheets.Count)
                DoEvents
            End If
        End If
    Else
        Sheets(SheetNum).Cells(LigneSel, colonneRecherchée + 1).Select
    End If
 '------------------------
End Sub

dans ... Sub AffichageFinal() ... j'ai annulé l'appel "Trier"....(j'ai pas compris la finalité

)

@+JP

**leaxel** · 25/08/2017, 16h21

bonjour et merci de ton aide,

j'ai tester rapidement ce tu as envoyé.
Mais sauf erreur de ma part (je le pense franchement lol), je n'ai pas réussi a la faire fonctionner.

LE MESSAGE D ERREUR

ERREUR DE COMPILATION
utilisation incorrecte du mot de clé Me
la ligne est la suivante :
Sub Initialisation()

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
 
 
    ColonLimit = Me.ColuMemns.Count - 1 ': MsgBox ColonLimit

voici ma macro aujourd'hui

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
 
Dim PartieMere As String
Dim PartieFille As String
Dim Rejeton As String
Dim PartieTraitee As String
Dim Origine As String
Dim DeuxiemeCar As String
Dim PremierCar As String
Dim Reste As String
 
Dim DateDebut As Variant
Dim TempsDebut As Variant
Dim DateFin As Variant
Dim TempsFin As Variant
 
Dim PositionCellule As Variant
Dim LigneRecherchée As Variant
 
Dim NbrCarMotEntier As Integer
Dim NbrCarPartieTraitee As Integer
Dim Cpt2Car As Integer
Dim Cpt3Car As Integer
Dim Cpt4Car As Integer
Dim Cpt5Car As Integer
Dim Cpt6Car As Integer
Dim Cpt7Car As Integer
Dim Cpt8Car As Integer
Dim Cpt9Car As Integer
Dim Cpt10Car As Integer
Dim Cpt11Car As Integer
Dim Cpt12Car As Integer
 
Dim ColonLimit As Integer
 
 
 
Sub Initialisation()
 '----- MODIF JP ---------
    Application.ScreenUpdating = False
    ColonLimit = Me.ColuMemns.Count - 1 ': MsgBox ColonLimit
    LigneFin = Range("A" & Rows.Count).End(xlUp).Row
    'boucle sur colon A
    For LigneSel = 1 To LigneFin
        Application.ScreenUpdating = True
        Application.ScreenUpdating = False
        SheetNum = 1
        Sheets(1).Select
        If Sheets(1).Range("A" & LigneSel).Value <> "" Then
           Sheets(1).Range("B" & LigneSel).Select
           PartieTraitee = Sheets(1).Range("A" & LigneSel).Value
           PartieFille = ""
           NbrCarMotEntier = Len(PartieTraitee)
           DateDebut = Date
           TempsDebut = Time
 
           Select Case NbrCarMotEntier
               Case Is < 3
                   Exit Sub
               Case Is <= 12
                   Traitement
               Case Is > 12
                   MsgBox "maxi 12 caractères"
            End Select
        End If
    Next LigneSel
    Sheets(1).Select
    Sheets(1).Cells(1, 1).Select
    Application.ScreenUpdating = True
 '------------------------
End Sub
 
Sub Traitement()
            Cpt2Car = 0
            Cpt3Car = 0
            Cpt4Car = 0
            Cpt5Car = 0
            Cpt6Car = 0
            Cpt7Car = 0
            Cpt8Car = 0
            Cpt9Car = 0
            Cpt10Car = 0
            Cpt11Car = 0
            Cpt12Car = 0
    Select Case NbrCarMotEntier
        Case 2
            GoTo Permutation2Caracteres
        Case 3
            GoTo Permutation3Caracteres
        Case 4
            GoTo Permutation4Caracteres
        Case 5
            GoTo Permutation5Caracteres
        Case 6
            GoTo Permutation6Caracteres
        Case 7
            GoTo Permutation7Caracteres
        Case 8
            GoTo Permutation8Caracteres
        Case 9
            GoTo Permutation9Caracteres
        Case 10
            GoTo Permutation10Caracteres
        Case 11
            GoTo Permutation11Caracteres
        Case 12
            GoTo Permutation12Caracteres
    End Select
 
Permutation12Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 12
    If NbrCarMotEntier = 12 And Cpt12Car = 12 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt12Car = 12 Then
        AffichageFinal
        Exit Sub
    End If
    Permutation
    Origine = PartieTraitee
    Cpt12Car = Cpt12Car + 1
 
Permutation11Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 11
    If NbrCarMotEntier = 11 And Cpt11Car = 11 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt11Car = 11 Then
        Cpt11Car = 0
        GoTo Permutation12Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt11Car = Cpt11Car + 1
 
Permutation10Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 10
    Permutation
    Origine = PartieTraitee
    Cpt10Car = Cpt10Car + 1
    If NbrCarMotEntier = 10 And Cpt10Car = 10 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt10Car = 10 Then
        Cpt10Car = 0
        GoTo Permutation11Caracteres
    End If
 
Permutation9Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 9
    If NbrCarMotEntier = 9 And Cpt9Car = 9 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt9Car = 9 Then
        Cpt9Car = 0
        GoTo Permutation10Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt9Car = Cpt9Car + 1
 
 
Permutation8Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 8
    If NbrCarMotEntier = 8 And Cpt8Car = 8 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt8Car = 8 Then
        Cpt8Car = 0
        GoTo Permutation9Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt8Car = Cpt8Car + 1
 
Permutation7Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 7
    If NbrCarMotEntier = 7 And Cpt7Car = 7 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt7Car = 7 Then
        Cpt7Car = 0
        GoTo Permutation8Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt7Car = Cpt7Car + 1
 
Permutation6Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 6
    If NbrCarMotEntier = 6 And Cpt6Car = 6 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt6Car = 6 Then
        Cpt6Car = 0
        GoTo Permutation7Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt6Car = Cpt6Car + 1
 
Permutation5Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 5
    If NbrCarMotEntier = 5 And Cpt5Car = 5 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt5Car = 5 Then
        Cpt5Car = 0
        GoTo Permutation6Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt5Car = Cpt5Car + 1
 
Permutation4Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 4
    If NbrCarMotEntier = 4 And Cpt4Car = 4 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt4Car = 4 Then
        Cpt4Car = 0
        GoTo Permutation5Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt4Car = Cpt4Car + 1
 
Permutation3Caracteres:
    Origine = PartieTraitee
    NbrCarPartieTraitee = 3
    If NbrCarMotEntier = 3 And Cpt3Car = 3 Then
        AffichageFinal
        Exit Sub
    End If
    If Cpt3Car = 3 Then
        Cpt3Car = 0
        GoTo Permutation4Caracteres
    End If
    Permutation
    Origine = PartieTraitee
    Cpt3Car = Cpt3Car + 1
 
Permutation2Caracteres:
    DeuxiemeCar = Mid(PartieTraitee, 2, 1)
    PremierCar = Left(PartieTraitee, 1)
    Reste = Mid(PartieTraitee, 3, NbrCarMotEntier - 1)
    PartieTraitee = DeuxiemeCar & PremierCar & Reste
    Affichage
    Cpt2Car = Cpt2Car + 1
    If Cpt2Car = 2 Then
        Cpt2Car = 0
        GoTo Permutation3Caracteres
    Else
        GoTo Permutation2Caracteres
    End If
End Sub
 
Sub Permutation()
    PartieTraitee = Left(Origine, NbrCarPartieTraitee)
    PartieMere = Mid(PartieTraitee, 2, NbrCarPartieTraitee - 1)
    Rejeton = Left(PartieTraitee, 1)
    If NbrCarMotEntier = NbrCarPartieTraitee Then
        PartieFille = ""
    Else
        PartieFille = Right(Origine, NbrCarMotEntier - NbrCarPartieTraitee)
    End If
    PartieTraitee = PartieMere & Rejeton & PartieFille
End Sub
 
Sub Affichage()
 '----- MODIF JP ---------
    ActiveCell.Value = PartieTraitee
    colonneRecherchée = ActiveCell.Column
    If colonneRecherchée = ColonLimit Then
        SheetNum = SheetNum + 1
        colonneRecherchée = 1
        If LigneSel = 1 Then
            Sheets.Add After:=Sheets(Sheets.Count)
            DoEvents
        Else
            If SheetNum < Sheets.Count Or SheetNum = Sheets.Count Then
                Sheets(SheetNum).Select
                Sheets(SheetNum).Cells(LigneSel, colonneRecherchée).Select
            Else
                Sheets.Add After:=Sheets(Sheets.Count)
                DoEvents
            End If
        End If
    Else
        Sheets(SheetNum).Cells(LigneSel, colonneRecherchée + 1).Select
    End If
 '------------------------
End Sub
 
 
 
 
Sub AffichageFinal()
    Application.ScreenUpdating = True
    Trier
    DateFin = Date
    TempsFin = Time
    MsgBox "la recherche a commencé le " & DateDebut & " à " & TempsDebut & " et fini le " & DateFin & " à " & TempsFin
End Sub
 
Sub Trier()
    For i = 1 To ColonLimit '16384 <-- MODIF ---
        Columns(i).Select
        If IsEmpty(ActiveCell.Offset(1, 0)) Then Exit Sub
        Selection.Sort Key1:=ActiveCell.Offset(1, 0), Order1:=xlAscending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    Next i
End Sub

Merci d'avance ,

Leaxel

Aide pour achever cette macro

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager