Numérotation multi niveau
jb_macro
Messages postés
2
Statut
Membre
-
f894009 Messages postés 17413 Statut Membre -
f894009 Messages postés 17413 Statut Membre -
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
A voir également:
- Numérotation multi niveau
- Youtube multi downloader - Télécharger - Conversion & Codecs
- Sfr multi - Accueil - Opérateurs & Forfaits
- Dans la présentation à télécharger, déplacez l'image dans le cadre sans en modifier la taille. redressez l'image pour que le niveau de la mer soit à l'horizontale. faites correspondre : la ligne avec le niveau de la mer ; le point avec le sommet de la grande voile. combien d'oiseaux sont dans le cadre ? - Forum Word
- Mise a niveau windows 7 vers 10 - Accueil - Mise à jour
- Problème numérotation page word saut de section ✓ - Forum Word
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
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
Ben vous n'aviez pas précisé ce petit détail!!!!
Encore dsl pour le manque de précision dans l Enonce de mon probleme
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