Creare un elenco numerato di titoli in excel come in word

[wallace&gromit]

Ciao,
vorrei creare una numerazione di titoli come in word però in excel.
Nella prima colonna della tabella da stampare avrò gerarchie di titoli 1, 2 e 3.
potrebbero essere così
1
1.1
1.1.1
1.1.2
1.1.3
1.2
2
2.1
ecc.

Vorrei fare la numerazione con dei calcoli, in modo da potere inserire nuove righe e automaticamente avere la numerazione corretta.
Ho provato un sistema in cui in una colonna d'appoggio inserisco il testo "Titolo1" oppure "Titolo2" o "Titolo3".
A fianco viene calcolato il numero progressivo.
Ho provato con un conta.se.
Mi funziona finché sono nel capitolo 1, ma quando passo al 2, col mio sistema, non riparto da 1 con la numerazione di "Titolo2", ma da quella ottenuta prima, nell'esempio sopra diventerebbe 2.3.

Qui quello che ho fatto, in colonna A quello che vorrei ottenere, in B il tipo di titolo e in C dovrebbe apparire la stessa numerazione come in A.

https://www.dropbox.com/s/zuhgi18pqnud5kn/Elenco%20capitoli%20numerato.xlsx?dl=0

Qualche idea?

[Anthony47]

Tanto vale farlo direttamente con una funzione utente:
-in un modulo standard del vba inserire il codice

Codice: Seleziona tutto

Function Numeraz(ByRef myRan As Range) As Variant
Dim Dizionario, wArr, tArr() As String, myMatch
Dim nArr() As Long
'
Dizionario = Array("Zc", "Titolo1", "Titolo2", "Titolo3", "Titolo4")      '<<< Zc + L'elenco dei livelli
'
ReDim nArr(1 To UBound(Dizionario) + 3)
wArr = myRan.Value
ReDim tArr(1 To UBound(wArr), 1 To 1)
For i = 1 To UBound(wArr)
    myMatch = Application.Match(wArr(i, 1), Dizionario, False)
    If Not IsError(myMatch) Then
        For j = myMatch To UBound(Dizionario)
            nArr(j) = 0
        Next j
        nArr(myMatch - 1) = nArr(myMatch - 1) + 1
    'End If
        For j = 1 To UBound(Dizionario)
            If nArr(j) > 0 Or nArr(j + 1) > 0 Or nArr(j + 2) > 0 Or nArr(j + 3) > 0 Then
                tArr(i, 1) = tArr(i, 1) & "." & nArr(j)
            End If
        Next j
        tArr(i, 1) = Mid(tArr(i, 1), 2)
    End If
Next i
Numeraz = tArr
End Function


Nota l'istruzione marcata <<<, che contiene la simbologia che adotterai per identificare capitoli /paragrafi /Sottoparagrafi, da personalizzare (il primo valore lascialo "Zc", sperando che tu non abbia l'intenzione di utilizzarlo)

Poi dove vuoi l'elenco numerato metti la formula

Codice: Seleziona tutto

=Numeraz(B1:B20)


Ovviamente da adattare al tuo elenco; restituira' tutto l'elenco
Come da immagine (formula in E1)


Prova...

[wallace&gromit]

Perfetto.
Hai messo alla prova la mia capacità investigativa , ma dopo un po' ho capito che andava trattata come formula matriciale.

Forse perché ho Office2019?

[wallace&gromit]

Segnalo però un altro problema:
la presenza della cella matriciale mi impedisce di inserire righe.
Attualmente devo togliere la formula e poi rimetterla, si può ovviare?

PS la velocità non è un requisito importante, il foglio viene ricalcolato raramente, quindi avere una macro che fa un calcolo un po' pedissequo per ogni cella della colonna B non sarebbe un problema, ma io mi ci perdo.

[Marius44]

Salve a tutti
Credo si possa fare senza UDF(Matriciale).
Guarda il codice seguente che scrive nella colonna J

Codice: Seleziona tutto

Sub Numera()
Dim ele
Dim i As Long, a As Long, b As Long, c As Long
a = 0: b = 0: c = 0
ele = Array("Zc", "Titolo1", "Titolo2", "Titolo3")
For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row
  If Cells(i, 2) = ele(1) Then
    a = a + 1
    b = 0: c = 0
    Cells(i, 10) = a
  ElseIf Cells(i, 2) = ele(2) Then
    b = b + 1
    Cells(i, 10) = a & "." & b
  ElseIf Cells(i, 2) = ele(3) Then
    c = c + 1
    Cells(i, 10) = a & "." & b & "." & c
  End If
Next i
End Sub


Fai sapere. Ciao,
Mario

[Anthony47]

...e se non risolvi col codice di Marius (vedi sopra) allora spiega con quale formula lavori, perche' io con =Numeraz(B1:B20) aggiungo senza problemi una riga all'interno dell'elenco preesistente.

[wallace&gromit]

Sì, la sub di Marius fa quello che voglio, ora bisognerebbe fare in modo che si ricalcoli automaticamente nel caso di modifiche (aggiunta o eliminazione di righe, modifica dell'ordine di un titolo, ecc.).

Con la funzione di Anthony se provo a inserire una riga mi dice "impossibile modificare una parte di una matrice".

[Anthony47]

Allora usa l'evento WorksheetChange per richiamare la sub di Mario; tipo:

Codice: Seleziona tutto

Private Sub Worksheet_Change(ByVal Target As Range)
'
ckArea = "C1:C100"      '<<< L'area dei titoli
'
If Not Application.Intersect(Target, Range(ckArea)) Is Nothing Then
    Call Numera
End If
End Sub

[wallace&gromit]

Funziona perfettamente,
ho aggiunto il Titolo4 e un controllo per verificare che i Titoli 3 e 4 siano sempre preceduti da 2 rispettivamente 3, senza salti.

Codice: Seleziona tutto

Sub Numera()
Dim ele
Dim i As Long, a As Long, b As Long, c As Long
a = 0: b = 0: c = 0: d = 0
ele = Array("Zc", "Titolo1", "Titolo2", "Titolo3", "Titolo4")

For j = 2 To Cells(Rows.Count, 2).End(xlUp).Row   'controlla la sequenza dei titoli
If Cells(j, 2) = ele(3) And Cells(j - 1, 2) = ele(1) Then
MsgBox ("Titolo3 senza Titolo2")
Exit Sub
End If
Next j
For l = 2 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(l, 2) = ele(4) And Cells(l - 1, 2) = ele(1) Or Cells(l, 2) = ele(4) And Cells(l - 1, 2) = ele(2) Then
MsgBox ("Titolo4 senza Titolo3")
Exit Sub
End If
Next l


For i = 1 To Cells(Rows.Count, 2).End(xlUp).Row   'scrive i titoli
  If Cells(i, 2) = ele(1) Then
    a = a + 1
    b = 0: c = 0: d = 0
    Cells(i, 10) = a
  ElseIf Cells(i, 2) = ele(2) Then
    b = b + 1
    c = 0: d = 0
    Cells(i, 10) = a & "." & b
  ElseIf Cells(i, 2) = ele(3) Then
    c = c + 1
    d = 0
    Cells(i, 10) = a & "." & b & "." & c
  ElseIf Cells(i, 2) = ele(4) Then
    d = d + 1
    Cells(i, 10) = a & "." & b & "." & c & "." & d
  End If
Next i
End Sub