Gruppierung per Makro

Hallo VBA Profis,
ich bräuchte bitte Eure Hilfe.
Wenn ich mir aus SAP eine Kostenartenstruktur in Excel ziehe und diese danach noch anpasse, zerhaut es die Gliederung.
Die Stufen der Kostenartenstruktur sind durch * gegennzeichnet.
Beispiel:
* Kostenerstattungen
** Sonstige Umsatzerlöse
*** Umsatzerlöse
**** Gesamtleistung
****** Jahresergebnis
Ich hatte mir so beholfen, dass ich mehrere Hilfsspalten eingebaut habe.
Erst habe ich mit folgender Formel die Anzahl der * ermittelt.
Spalte G =LÄNGE(H2)-LÄNGE(WECHSELN(H2;"*";))
dann
Spalte F ==WENN($G1>=1;$G1;0)
Spalte E ==WENN($G1>=2;$G1;0)
etc.
Danach die Formeln in Werte umgewandelt und alle mit Wert Null gelöscht.
Danach habe ich folgendes Makro laufen lassen.


Sub Gruppieren5a()
Dim rng As Range
For Each rng In Columns(5).SpecialCells(xlCellTypeBlanks).Areas
rng.EntireRow.Group
Next
ActiveSheet.Outline.ShowLevels RowLevels:=1
Call Gruppieren4a  (Das Gkleiche für Spalte 4)
Call Gruppieren3
Call Gruppieren2
Call Gruppieren1
End Sub

Ich finde dies jedoch sehr umständlich und bin mir sicher, dass dies alles in einem Makro gemacht werden kann.
Vorab schon einmal vielen Dank für Eure Hilfe
VG
Stefan

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

'Code in einem allgemeinen Modul Sub Gruppieren() Dim wks As Worksheet Dim Zeile As Long, Zeile1 As Long, Zeile2 As Long, Zeile_L As Long Dim arrLevel() As Long Dim GroupMax As Long, Group As Long Const SpalteGroup As Long = 8 'Spalte mit * zur Gruppierungskennzeichnung - ggf. anpassen Const Zeile_S As Long = 2 'Startzeile für die Gruppierung - ggf. anpassen Set wks = ActiveWorkbook.Worksheets("Tabelle1") ' oder = ActiveSheet - ggf. anpassen With wks .Activate 'letzte zeile in Gruppierungsspalte Zeile_L = .Cells(.Rows.Count, SpalteGroup).End(xlUp).Row 'vorhandene Gliederung entfernen With .Range(.Rows(Zeile_S), .Rows(Zeile_L)) .ClearOutline End With 'Gruppierungsebene für jede Zeile ermitteln und in Daten-Array speichern ReDim arrLevel(Zeile_S To Zeile_L) For Zeile = Zeile_S To Zeile_L arrLevel(Zeile) = Len(.Cells(Zeile, SpalteGroup)) _ - Len(VBA.Replace(.Cells(Zeile, SpalteGroup), "*", "")) If GroupMax

'Gruppierungsebene für jede Zeile ermitteln und in Daten-Array speichern ReDim arrLevel(Zeile_S To Zeile_L) For Zeile = Zeile_S To Zeile_L arrLevel(Zeile) = Len(.Cells(Zeile, SpalteGroup)) _ - Len(VBA.Replace(.Cells(Zeile, SpalteGroup), "*", "")) If arrLevel(Zeile) > 7 Then arrLevel(Zeile) = 7 'neue Zeile If GroupMax

Beliebteste Forumthreads (12 Monate)

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread