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 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 - 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

A voir également:

1 réponse

Réponse 1 / 1

f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701
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

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

f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701
10 mai 2018 à 13:39

Bonjour
Ben vous n'aviez pas précisé ce petit détail!!!!

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

f894009 Messages postés 17185 Date d'inscription dimanche 25 novembre 2007 Statut Membre Dernière intervention 15 avril 2024 1 701
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

Discussions similaires

Continuer numérotation des pages après saut de section

Recherche multi exp dans pokémon heart gold

comment numéroter les page ( pour 30 pages)

Multi Exp dans Pokemon Diamant

problème de numérotation des pages avec Word

Discussions similaires

Newsletters