Numérotation multi niveau

jb_macro -  
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

  1.  f894009
    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
    1. jb_macro Auteur
      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
    2. f894009
      Bonjour
      Ben vous n'aviez pas précisé ce petit détail!!!!
      0
    3. Jb_macro
      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
    4. f894009
      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

Problème sur le câble d'antenne canal+
Kadi

5 réponses
Continuer numérotation des pages après saut de section
dsjl

13 réponses
surcharge d' antenne
rambo2317

8 réponses
probléme tnt surcharge du cable lnb
cidark

21 réponses
problème de numérotation des titres
ameu00

2 réponses