Sujet Précédent Sujet Suivant

Numérotation multi niveau

Fermé
jb_macro Messages postés 2 Date d'inscription vendredi 4 mai 2018 Statut Membre Dernière intervention 10 mai 2018 - 4 mai 2018 à 11:50
f894009 Messages postés 17229 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 21 janvier 2025 - 11 mai 2018 à 14:42
Bonjour

Je souhaiterais, à l'aide d'une Macro, automatiser la numérotation de mes lignes, dans la colonne B, sur plusieurs niveaux (01, 01.01 et 01.01.01.....) selon un repère (1, 2 et 3.....) dans colonne A

Le nombre de niveau est variable , mais peut aller jusque 20



J'ai trouvé une code VBA qui le fait très bien, mais qui ne gère que 3 niveau avec une numération (1, 1.1 et 1.1.1)



Je débute en vba, et je n'arrive pas a l'adapter





https://www.commentcamarche.net/forum/affich-4092209-excel-numerotation-sur-plusieurs-niveaux



Sub NOMMACRO()

Dim i%, j%, k%, Arr%(1 To 99)

With Worksheets("Métré")

j = .Range("A65536").End(xlUp).Row

.Range(.Cells(2, 2), .Cells(j, 3)).Font.Bold = False

.Range(.Cells(2, 3), .Cells(j, 3)).Font.Underline = xlUnderlineStyleNone

For i = 2 To j

k = .Cells(i, 1)

If k > 0 Then

.Cells(i, 3) = IIf(k = 1, UCase(.Cells(i, 3)), LCase(.Cells(i, 3)))

Arr(k) = Arr(k) + 1

If k < 2 Then Arr(2) = 0

If k < 3 Then Arr(3) = 0

If k = 1 Then

.Cells(i, 2) = Chr(160) & Arr(1)

.Range(.Cells(i, 2), .Cells(i, 3)).Font.Bold = True

.Cells(i, 3).Font.Underline = xlUnderlineStyleSingle

End If

If k = 2 Then .Cells(i, 2) = Chr(160) & Chr(160) & Arr(1) & "." & Arr(2)

If k = 3 Then .Cells(i, 2) = Chr(160) & Chr(160) & Chr(160) & Arr(1) & "." & Arr(2) & "." & Arr(3)

If k > 3 Then .Range(.Cells(i, 1), .Cells(i, 2)).ClearContents

Else

.Cells(i, 2).ClearContents

End If

Next

.Cells(i, 1).Activate

End With

End Sub





Merci d'avance pour votre aide !



Jerem

1 réponse

Réponse 1 / 1
f894009 Messages postés 17229 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 21 janvier 2025 1 712
4 mai 2018 à 13:45
Bonjour, 

Sub NOMMACRO()
    Dim i As Long, j As Long, k As Long, Arr(1 To 99)   As Long

    With Worksheets("Métré")
        j = .Range("A65536").End(xlUp).Row
        .Range(.Cells(2, 2), .Cells(j, 3)).Font.Bold = False
        .Range(.Cells(2, 3), .Cells(j, 3)).Font.Underline = xlUnderlineStyleNone
        For i = 2 To j
            k = .Cells(i, 1)
            If k > 0 Then
                .Cells(i, 3) = IIf(k = 1, UCase(.Cells(i, 3)), LCase(.Cells(i, 3)))
                Arr(k) = Arr(k) + 1
                If k < 2 Then Arr(2) = 0
                If k < 3 Then Arr(3) = 0
                If k < 4 Then Arr(4) = 0
                If k = 1 Then
                    .Cells(i, 2) = Chr(160) & Arr(1)
                    .Range(.Cells(i, 2), .Cells(i, 3)).Font.Bold = True
                    .Cells(i, 3).Font.Underline = xlUnderlineStyleSingle
                End If
                If k = 2 Then
                    .Cells(i, 2) = Chr(160) & Chr(160) & Arr(1) & "." & Arr(2)
                ElseIf k = 3 Then
                    .Cells(i, 2) = Chr(160) & Chr(160) & Chr(160) & Arr(1) & "." & Arr(2) & "." & Arr(3)
                ElseIf k = 4 Then
                    .Cells(i, 2) = Chr(160) & Chr(160) & Chr(160) & Chr(160) & Arr(1) & "." & Arr(2) & "." & Arr(3) & "." & Arr(4)
                ElseIf k > 4 Then
                    .Range(.Cells(i, 1), .Cells(i, 2)).ClearContents
                End If
            Else
                .Cells(i, 2).ClearContents
            End If
        Next
        .Cells(i, 1).Activate
    End With

End Sub
0
jb_macro Messages postés 2 Date d'inscription vendredi 4 mai 2018 Statut Membre Dernière intervention 10 mai 2018
10 mai 2018 à 11:39
Dsl pour la réponse tardive. j'ai compris la structure vba pour la macro, et j'ai su la faire fonctionner jusqu’à 15 niveau.
J'ai tjs le problème de format sur le code. la numérotation est 1.1.1.1 et non 01.01.01.01
0
f894009 Messages postés 17229 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 21 janvier 2025 1 712
10 mai 2018 à 13:39
Bonjour
Ben vous n'aviez pas précisé ce petit détail!!!!
0
Jb_macro
10 mai 2018 à 15:26
Dsl, je pensai que c était clair qd j ai noté " sur plusieurs niveaux (01, 01.01 et 01.01.01.....)" mais ce n était pas forcément clair, dsl. En complément j ajouterai que un fois arriver à 09 j aimerai bien avoir 10 et pas 010.
Encore dsl pour le manque de précision dans l Enonce de mon probleme
0
f894009 Messages postés 17229 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 21 janvier 2025 1 712
Modifié le 11 mai 2018 à 15:06
Bonjour, 

Sub NOMMACRO()
    Dim i As Long, j As Long, k As Long, Arr(1 To 99) As Long

    With Worksheets("Métré")
        j = .Range("A65536").End(xlUp).Row
        .Range(.Cells(2, 2), .Cells(j, 3)).Font.Bold = False
        .Range(.Cells(2, 3), .Cells(j, 3)).Font.Underline = xlUnderlineStyleNone
        For i = 2 To j
            k = .Cells(i, 1)
            If k > 0 Then
                .Cells(i, 3) = IIf(k = 1, UCase(.Cells(i, 3)), LCase(.Cells(i, 3)))
                Arr(k) = Arr(k) + 1
                If k < 2 Then Arr(2) = 0
                If k < 3 Then Arr(3) = 0
                If k < 4 Then Arr(4) = 0
                If k = 1 Then
                    .Cells(i, 2) = Chr(160) & Arr(1)
                    .Range(.Cells(i, 2), .Cells(i, 3)).Font.Bold = True
                    .Cells(i, 3).Font.Underline = xlUnderlineStyleSingle
                End If
                If k = 2 Then
                    .Cells(i, 2) = String(2, Chr(160)) & Format(Arr(1), "00") & "." & Format(Arr(2), "00")
                ElseIf k = 3 Then
                    .Cells(i, 2) = String(3, Chr(160)) & Format(Arr(1), "00") & "." & Format(Arr(2), "00") & "." & Format(Arr(3), "00")
                ElseIf k = 4 Then
                    .Cells(i, 2) = String(4, Chr(160)) & Format(Arr(1), "00") & "." & Format(Arr(2), "00") & "." & Format(Arr(3), "00") & "." & Format(Arr(4), "00")
                ElseIf k > 4 Then
                ElseIf k > 4 Then
                    .Range(.Cells(i, 1), .Cells(i, 2)).ClearContents
                End If
            Else
                .Cells(i, 2).ClearContents
            End If
        Next
        .Cells(1, 1).Activate
    End With

End Sub
0

Discussions similaires

Recherche multi exp dans pokémon heart gold
tom -
Estebalignon -

6 réponses
2eme multi exp?
sohanejeff30 -
missing you -

1 réponse
Pokémon SoulSilver multi exp
Randy62 -
rieulebg -

8 réponses
Multi Exp dans Pokemon Diamant
Tomoko -
lol -

63 réponses
probleme sommet
urgent -
Raymond PENTIER -

2 réponses