Problème macro Excel

Résolu/Fermé
nicket96 Messages postés 2 Date d'inscription mardi 23 octobre 2007 Statut Membre Dernière intervention 29 octobre 2007 - 25 oct. 2007 à 13:29
nicket96 Messages postés 2 Date d'inscription mardi 23 octobre 2007 Statut Membre Dernière intervention 29 octobre 2007 - 29 oct. 2007 à 11:50
Bonjour à tous,

Je suis nouvel utilisateur Excel et VBA et j'ai un problème particulier à vous soumettre.
J'ai un fichier de données chiffrées qui contient des nombres normalement de 5 chiffres (n° internes de téléphone). Le problème est que la machine qui génère ces données fournit des données tronquées en cas de série complète (par exemple : 3012 pour dire tous les nombres compris entre 30120 et 30129 ou 345 pour tous les nombres compris entre 34500 et 34599). Le but de l'opération est d'étendre toutes les séries troquées afin d'avoir une liste complète. En plus, il s'agit de garder la mise en page sur 10 colonnes. J'ai pratiquement réussi à tout faire dans une macro mais il ne traite pas correctement certains cas et j'ignore pourquoi.

Voici un bout du fichier original :

30012 30051 30061 30065 30069 30070 30080 30090 30097 30098
30099 30100 30101 30102 30103 30104 30107 30108 30109 30110
30112 30113 30114 30116 30117 30118 30119 30120 30122 30123
30124 30126 30127 30128 30129 3013 3014 3015 3016 3017
3018 3019 30203 30206 30207 30208 30209 3021 30230 30233
30234 30235 30236 30237 30238 30239 3024 3025 30260 30263
30264 30265 30266 30267 30268 30269 3027 30280 30281 30282
30283 30285 30286 30287 30288 30289 3029 30300 30303 30304
30305 30306 30307 30308 30309 30310 30311 30312 30318 30319
30330 30331 30332 30335 30336 30337 30352 30355 30359 3036
30530 30534 30539 30540 30542 30543 30544 30545 30546 30547
30548 30549 3055 30560 30561 30562 30564 30565 30566 30567
30568 30594 30595 30596 30601 30604 30605 30606 30607 30609
30610 30611 30612 30615 30620 30622 30623 30624 30625 30626
30628 30629 30647 30648 30649 3065 3066 3067 3068 3069
307 30807 30808 30809 30812 30813 30814 30815 30816 30817
30818 30819 3083 3084 3085 3086 30870 30874 30875 30876
30877 30878 30879 3088 30890 30892 30895 30896 30899 30901
30902 30903 30904 30905 30927 30930 30931 30932 30933 30934
30935 30938 3094 3095 3096 3097 3098 3099 310 3110
31110 31112 31113 31114 31115 31116 31117 31118 31119 3112
3113 3114 3115 3116 3117 31180 31181 31182 31183 31184
31186 31187 31188 31189 31190 31191 31210 31211 31212 31242
31243 31244 31270 31280 31300 31308 31321 31322 31323 31324
31328 31329 31335 31336 31337 31338 31339 31342 31344 31345
31346 31347 31348 31349 31350 31360 31362 31363 31364 31365
31366 31367 31368 31369 31370 31371 31372 31373 31374 31375
31376 31379 31385 31388 31389 31390 31395 31396 31397 31398
31399 31400 31401 31413 3142 3143 3144 3145 3146 3147
31485 31487 31492 31493 31495 31496 31497 31498 31499 3150
31510 31511 31512 31513 31514 31516 31517 31518 31519 3152
31530 31531 31532 31533 31534 31535 31536 31537 31538 31540
31542 31543 31544 31545 31547 31553 31554 31555 31556 31557
31558 31559 3156 3157 3158 3159 31600 31610 31639 31648
31670 31680 31686 31707 31755 31772 31774 31815 31816 31817
31818 31819 31820 31830 31839 31840 31844 31845 31850 31855
31860 31863 31864 31865 31866 31867 31868 31869 31877 31878
31880 31885 31915 31919 31920 31931 31962 31963 31964 31965
31966 31967 31968 31969 31971 31972 31973 31974 31977 31979
31983 31984 31985 31986 31987 31988 31993 31994 31995 31997

Et voici mon code :

Option Explicit

Public Sub TriTelephone()


''MISE EN COLONNES

Application.ScreenUpdating = False

''MET TOUS LES NUMEROS SUR LA PREMIERE COLONNE
Dim intCol As Integer
Dim i

Range("A1").End(xlToRight).Select
intCol = ActiveCell.Column

For i = 2 To intCol
Cells(1, i).Select
Range(Selection, Selection.End(xlDown)).Cut
Range("A1").End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
ActiveSheet.Paste
Next i


''AJOUTER NUMEROS MANQUANTS

Dim intLigne As Integer
Dim j As Byte
Dim k
Dim l As Byte

Range("A1").End(xlDown).Select
intLigne = ActiveCell.Row


For Each k In Range(Cells(1, 1), Cells(intLigne, 1))

If Len(k) = 4 Then
For j = 0 To 9
Range("A1").End(xlDown).Offset(1, 0) = k & j
Next j
End If

If Len(k) = 3 Then

For j = 10 To 99
Range("A1").End(xlDown).Offset(1, 0) = k & j
Next j

For l = 0 To 9
Range("A1").End(xlDown).Offset(1, 0) = k & "0" & l
Next l

End If

Next k



''SUPPRESSION NUMEROS COURTS
Dim intRow
Dim m

Range("A1").End(xlDown).Select
intRow = ActiveCell.Row

For Each m In Range(Cells(1, 1), Cells(intRow, 1))

If Len(m) = 4 Or Len(m) = 3 Then
m.Delete Shift:=xlUp
End If

Next m


''TRI PAR ORDRE CROISSANT
Columns("A:A").Select
Application.CutCopyMode = False
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

''MISE EN TABLEAU
Dim intRangFinal As Integer
Dim x

Range("A1").End(xlDown).Select
intRangFinal = ActiveCell.Row


Range("A1:A10").Select ''CHANGER 2e RANGE POUR CHANGER LE NOMBRE DE COLONNES
Selection.Copy
Range("B1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

Range("A11:A20").Select ''CHANGER 2e RANGE POUR CHANGER LE NOMBRE DE COLONNES
Selection.Copy
Range("B2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True

Range("A1:A20").Clear ''CHANGER 2e RANGE POUR CHANGER LE NOMBRE DE COLONNES


If intRangFinal Mod 10 = 0 Then ''ADAPTER POUR LE BON NOMBRE DE COLONNES
intRangFinal = intRangFinal / 10 ''ADAPTER POUR LE BON NOMBRE DE COLONNES
Else
intRangFinal = intRangFinal \ 10 + 1 ''ADAPTER POUR LE BON NOMBRE DE COLONNES
End If

For x = 1 To intRangFinal

Range("A1").End(xlDown).Select

If Selection = Range("A65536") Then
Range("A1").Select
Application.ScreenUpdating = True

''SUPPRESSION COLONNE A
Columns("A:A").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
Application.ScreenUpdating = False
Exit Sub
End If

ActiveCell.Range("A1:A10").Select ''ADAPTER POUR LE BON NOMBRE DE COLONNES
Selection.Copy
Range("B1").Select
Selection.End(xlDown).Select
ActiveCell.Offset(1, 0).Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Range("A1").End(xlDown).Select
ActiveCell.Range("A1:A10").Select ''ADAPTER POUR LE BON NOMBRE DE COLONNES
Selection.Clear

Next x


End Sub

Et voici le résultat :

3021 3027 3088 3112 3150 3809 30012 30051 30061 30065
30069 30070 30080 30090 30097 30098 30099 30100 30101 30102
30103 30104 30107 30108 30109 30110 30112 30113 30114 30116
30117 30118 30119 30120 30122 30123 30124 30126 30127 30128
30129 30130 30131 30132 30133 30134 30135 30136 30137 30138
30139 30140 30141 30142 30143 30144 30145 30146 30147 30148
30149 30150 30151 30152 30153 30154 30155 30156 30157 30158
30159 30160 30161 30162 30163 30164 30165 30166 30167 30168
30169 30170 30171 30172 30173 30174 30175 30176 30177 30178
30179 30180 30181 30182 30183 30184 30185 30186 30187 30188
30189 30190 30191 30192 30193 30194 30195 30196 30197 30198
30199 30203 30206 30207 30208 30209 30210 30211 30212 30213
30214 30215 30216 30217 30218 30219 30230 30233 30234 30235
30236 30237 30238 30239 30240 30241 30242 30243 30244 30245
30246 30247 30248 30249 30250 30251 30252 30253 30254 30255
30256 30257 30258 30259 30260 30263 30264 30265 30266 30267
30268 30269 30270 30271 30272 30273 30274 30275 30276 30277
30278 30279 30280 30281 30282 30283 30285 30286 30287 30288
30289 30290 30291 30292 30293 30294 30295 30296 30297 30298
30299 30300 30303 30304 30305 30306 30307 30308 30309 30310
30311 30312 30318 30319 30330 30331 30332 30335 30336 30337
30352 30355 30359 30360 30361 30362 30363 30364 30365 30366
30367 30368 30369 30530 30534 30539 30540 30542 30543 30544
30545 30546 30547 30548 30549 30550 30551 30552 30553 30554
30555 30556 30557 30558 30559 30560 30561 30562 30564 30565
30566 30567 30568 30594 30595 30596 30601 30604 30605 30606
30607 30609 30610 30611 30612 30615 30620 30622 30623 30624
30625 30626 30628 30629 30647 30648 30649 30650 30651 30652
30653 30654 30655 30656 30657 30658 30659 30660 30661 30662
30663 30664 30665 30666 30667 30668 30669 30670 30671 30672
30673 30674 30675 30676 30677 30678 30679 30680 30681 30682
30683 30684 30685 30686 30687 30688 30689 30690 30691 30692
30693 30694 30695 30696 30697 30698 30699 30700 30701 30702
30703 30704 30705 30706 30707 30708 30709 30710 30711 30712
30713 30714 30715 30716 30717 30718 30719 30720 30721 30722
30723 30724 30725 30726 30727 30728 30729 30730 30731 30732
30733 30734 30735 30736 30737 30738 30739 30740 30741 30742
30743 30744 30745 30746 30747 30748 30749 30750 30751 30752
30753 30754 30755 30756 30757 30758 30759 30760 30761 30762
30763 30764 30765 30766 30767 30768 30769 30770 30771 30772
30773 30774 30775 30776 30777 30778 30779 30780 30781 30782
30783 30784 30785 30786 30787 30788 30789 30790 30791 30792
30793 30794 30795 30796 30797 30798 30799 30807 30808 30809
30812 30813 30814 30815 30816 30817 30818 30819 30830 30831
30832 30833 30834 30835 30836 30837 30838 30839 30840 30841
30842 30843 30844 30845 30846 30847 30848 30849 30850 30851
30852 30853 30854 30855 30856 30857 30858 30859 30860 30861
30862 30863 30864 30865 30866 30867 30868 30869 30870 30874
30875 30876 30877 30878 30879 30880 30881 30882 30883 30884
30885 30886 30887 30888 30889 30890 30892 30895 30896 30899

Voilà.

Merci d'avance
A voir également:

2 réponses

gbinforme Messages postés 14946 Date d'inscription lundi 18 octobre 2004 Statut Contributeur Dernière intervention 24 juin 2020 4 685
26 oct. 2007 à 14:20
bonjour

Ton code est très long pour être sûr d'avoir tout vu mais dans ta séquence "''AJOUTER NUMEROS MANQUANTS "
Il me semble que cela fonctionnerait plus correctement avec la méthode suivante qui prend les lignes dans l'ordre et met les générés en fin.
For k = 1 To intLigne

If Len(Cells(k, 1)) = 4 Then
    For j = 0 To 9
        Range("A1").End(xlDown).Offset(1, 0) = Cells(k, 1) & j
    Next j
End If

If Len(Cells(k, 1)) = 3 Then
    For j = 0 To 99
        Range("A1").End(xlDown).Offset(1, 0) = Cells(k, 1) & Format(j, "00")
    Next j
End If

Next k

De même il y a un problème dans ''SUPPRESSION NUMEROS COURTS car lorsque tu supprime il faut toujours commencer par en bas sinon tu loupes des lignes car le delete passe à la ligne suivante.
For m = intRow To 1 Step -1

If Len(Cells(m, 1)) = 4 Or Len(Cells(m, 1)) = 3 Then
    Cells(m, 1).Delete Shift:=xlUp
End If

Next m

Ainsi, ta macro devrait être correcte et tiens nous au courant.
0
nicket96 Messages postés 2 Date d'inscription mardi 23 octobre 2007 Statut Membre Dernière intervention 29 octobre 2007
29 oct. 2007 à 11:50
Salut,

Merci beaucoup de ta réponse, cela a été très utile et fonctionne maintenant à merveille !

Bonne journée
0