Numérotation multi niveau
jb_macro
Messages postés
2
Statut
Membre
-
f894009 Messages postés 17417 Date d'inscription Statut Membre Dernière intervention -
f894009 Messages postés 17417 Date d'inscription Statut Membre Dernière intervention -
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
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
-
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-
-
-
-
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
-
