Excel VBA Formatierung

Hallo VBA-Profis :-)
Ich hoffe, dass mir jemand bei meinem Problem helfen kann. Und zwar habe ich bisher folgende Daten beginnend in Zelle A1 bzw. B1 angelegt:
A Text
A1 Text
A11 Text
A111 Text
A1111 Text
A1112 Text
A1113 Text
A1114 Text
A1115 Text
A1116 Text
A1117 Text
A112 Text
A113 Text
A1131 Text
A1132 Text
A1133 Text
A12 Text
A121 Text
A1211 Text
A1212 Text
A1213 Text
A1214 Text
A1215 Text
A1216 Text
A1217 Text
A122 Text
A123 Text
A124 Text
A1241 Text
A1242 Text
A1243 Text
A125 Text
A126 Text
A127 Text
Nun hätte ich gerne, dass jeweils die kleinste, vorhandene - ich nenne es mal Unterkategorie in Spalte A - sowie der entsprechende Text in Spalte B fett markiert wird wie ich es bereits oben angedeutet habe. Das Problem ist hierbei eben das, dass die kleinsten Unterkategorien unterschiedliche Längen aufweisen bzw. die Gliederungstiefe variiert, z.B. A1241 und A125. Letztere muss jedoch logischerweise, da keine weiteren Unterkategorien wie A1251 vorhanden sind, ebenso markiert werden.
Excel muss also diejenige Unterkategorie erkennen, ab welcher nicht weiter aufgesplittet wird und die entsprechenden Werte UND die Texte in Spalte B fett markieren.
Bisher habe ich folgende Sub:

Sub markieren()
Dim ende As Long
Dim werte()
Dim zeile As Long
Dim suchwert As String
Dim temp
ende = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
ReDim werte(ende)
For zeile = ende To 1 Step -1
suchwert = ActiveSheet.Cells(zeile, 1)
temp = Filter(werte, suchwert, , vbTextCompare)
If UBound(temp) = -1 Then
werte(0) = werte(0) + 1
werte(werte(0)) = suchwert
ActiveSheet.Cells(zeile, 1).Font.Bold = True
End If
Next zeile
End Sub

Diese funktioniert auf den ersten Zellen einwandfrei, nur dann schleichen sich Fehler ein. Beispielsweise habe ich Zellen bei denen die Markierung erst später einsetzt und das dann so aussieht:
A121 Text
A1211 Text
A1212 Text
A1213 Text
A1214 Text
A1215 Text
A1216 Text
A1217 Text
Ich hoffe, ich konnte das Problem hinreichend erklären und mir kann i-jemand helfen. Danke im Voraus

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub BoldSetzen() Dim rng As Range Dim strWert As String Dim strVergleich As String Dim i As Long Dim lastRow As Long lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False For i = 1 To lastRow strWert = ActiveSheet.Range("A" & i).Text strVergleich = ActiveSheet.Range("A" & i + 1).Text Set rng = ActiveSheet.Range("A" & i + 1) With ActiveSheet Range("A" & i).Font.Bold = True If InStr(rng, strWert) > 0 Then .Range("A" & i + 1).Font.Bold = True .Range("A" & i).Font.Bold = False End If If Right$(strVergleich, 1) > Right$(strWert, 1) Then .Range("A" & i + 1).Font.Bold = True End If End With If ActiveSheet.Range("A" & i).Font.Bold = True Then ActiveSheet.Range("B" & i).Font.Bold = True Next i Application.ScreenUpdating = True Set rng = Nothing End Sub

Sub BoldSetzen() Dim rng As Range Dim strWert As String Dim i As Long Dim lastRow As Long lastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row Application.ScreenUpdating = False ActiveSheet.Columns("A:B").Font.Bold = True For i = 1 To lastRow strWert = ActiveSheet.Range("A" & i).Text Set rng = ActiveSheet.Range("A" & i + 1) With ActiveSheet If InStr(rng, strWert) > 0 Then .Range("A" & i).Font.Bold = False .Range("B" & i).Font.Bold = False End If End With Next i Application.ScreenUpdating = True Set rng = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread