Nummerierung bei Einrücken des Textes erweitern

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Function AnzahlZeichen(TextZelle As Range, SuchString As String) Dim lngCnt With TextZelle.Cells(1, 1) AnzahlZeichen = 0 For lngCnt = 1 To Len(.Text) If Mid(.Text, lngCnt, 1) = SuchString Then _ AnzahlZeichen = AnzahlZeichen + 1 Next lngCnt End With End Function Sub Leerzeichen() Dim i As Long Dim letztezeile As Long letztezeile = ActiveSheet.Cells(1048576, 1).End(xlUp).Row For i = 1 To letztezeile If AnzahlZeichen(Cells(i, 1), ".") = 1 Then Cells(i, 2).Value = " " & Cells(i, 2) End If If AnzahlZeichen(Cells(i, 1), ".") = 2 Then Cells(i, 2).Value = " " & Cells(i, 2) End If Next i End Sub

Private Sub Worksheet_Change(ByVal Target As Range) If Target.Column = 1 Then If Target = "" Then Target.Offset(0, 1).IndentLevel = 0: Exit Sub Target.Offset(0, 1).IndentLevel = UBound(Split(Target, ".")) End If End Sub

Nein leider nicht - seht Euch bitte nochmal das Bild "vorher" und "nachher" im Eröffnungsthread an - ich ändere nur in Spalte B die Einrückung und dann soll sich die Nummerierung autom. anpassen:
Also nochmals zur Erklärung - der Ausgangszustand:
Userbild

Und so soll es aussehen, wenn Zeile 2, 3 und 7 einmal eingerückt wurde (daher die Nummern erweitert auf *.1) und Zeile 8 zweimal eingerückt wurde (daher die Nummer erweitert auf *.1.1):
Userbild

ACHTUNG - natürlich soll sich durch das Einrücken und folglich Nummern-Erweiterung die fortlaufende Nummerierung automatisch anpassen!
Ich hoffe, meine Anforderung ist nun klarer - viel Spaß beim Tüfteln und Danke im Voraus für Eure Unterstützung!!!
Lg,
Chrisi

Sub Machen2() Dim a(), i&, k&, maxZ&, ll&, aus$() maxZ = Range("B" & Rows.Count).End(xlUp).Row ReDim a(1 To maxZ, 3) ReDim aus(2 To maxZ, 0) For k = 0 To 3: For i = 1 To maxZ: a(i, k) = 0: Next: Next ll = 1 For i = 2 To maxZ a(i, 0) = Range("B" & i).IndentLevel + 1 If a(i, 0) = ll Then For k = 1 To 3: a(i, k) = a(i - 1, k): Next a(i, ll) = a(i - 1, ll) + 1 Else If a(i, 0) < ll Then ll = a(i, 0) a(i, ll) = a(i - 1, ll) + 1 For k = 1 To ll - 1: a(i, k) = a(i - 1, k): Next Else If a(i, 0) > ll Then For k = 1 To a(i, 0) - 1: a(i, k) = a(i - 1, k): Next a(i, a(i, 0)) = a(i - 1, a(i, 0)) + 1 ll = a(i, 0) End If End If End If For k = 1 To ll: aus(i, 0) = aus(i, 0) & a(i, k) & ".": Next aus(i, 0) = Left(aus(i, 0), Len(aus(i, 0)) - 1) Next Range("D1:G" & maxZ) = a ' diese Zeile ggf. löschen... Range("A2:A" & maxZ) = aus End Sub

Hi Chrisi,
die Fehlermeldung paßt nicht, aber ich hab jetzt keine Zeit, und arbeiten läßt sich's damit:

Sub Machen2()
Dim a(), i&, k&, maxZ&, ll&, aus$()
Const maxArr = 4        ' *** neu ***
maxZ = Range("B" & Rows.Count).End(xlUp).Row
ReDim a(1 To maxZ, maxArr)
ReDim aus(2 To maxZ, 0)
For k = 0 To maxArr: For i = 1 To maxZ: a(i, k) = 0: Next: Next
ll = 1
For i = 2 To maxZ
a(i, 0) = Range("B" & i).IndentLevel + 1
If a(i, 0) > maxArr Then _
MsgBox "Nr. " & i & "zu tief eingerückt": a(i, 0) = maxArr
If a(i, 0) = ll Then
For k = 1 To maxArr: a(i, k) = a(i - 1, k): Next
a(i, ll) = a(i - 1, ll) + 1
Else
If a(i, 0) < ll Then
ll = a(i, 0)
a(i, ll) = a(i - 1, ll) + 1
For k = 1 To ll - 1: a(i, k) = a(i - 1, k): Next
Else
If a(i, 0) > ll Then
For k = 1 To a(i, 0) - 1: a(i, k) = a(i - 1, k): Next
a(i, a(i, 0)) = a(i - 1, a(i, 0)) + 1
ll = a(i, 0)
End If
End If
End If
For k = 1 To ll: aus(i, 0) = aus(i, 0) & a(i, k) & ".": Next
aus(i, 0) = Left(aus(i, 0), Len(aus(i, 0)) - 1)
Next
' Range("D1:G" & maxZ) = a ' diese Zeile ggf. löschen...
Range("A2:A" & maxZ) = aus
End Sub

LG,
Michael

Beliebteste Forumthreads (12 Monate)

Nummerierung bei Einrücken des Textes erweitern

18 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

18
Beiträge zum Forumthread

Beiträge zu diesem Forumthread