flexible Tabellenprogrammierung

Hallo nochmal, ich möchte die Frage nochmal in die Runde stellen, weil ich das Problem dringend lösen muss. Falls es nicht über Makroprogrammierung gelöst werden kann, lasst es mich bitte wissen. Falls jemand einen Lösungsansatz hat, wäre ich sehr glücklich, sitze schon ziemlich lange daran. Hier nochmal die Frage:
Ich benötige ein Makro, das für eine flexible Anzahl von Daten diese gruppiert. Bsp:
Daten:
A1;A;10%
A2;A;20%
A3;A;5%
B1;B;15%
B2;B;3%
B3;B;2%
B4;B;10%
C1;C;20%
C2;C;10%
D1;D;10%
A,B,C,D sind Gruppen, A1,... die Mitglieder dieser Gruppe. Es müssen nicht alle 4 Gruppen vorhanden sein, aber es sind höchstens diese 4. Die Anzahl der Gruppenmitglieder ist variabel.
Als Ergebnis benötige ich eine Exceltabelle, die diese Daten nach Gruppen und innerhalb der Gruppe nach Gewicht sortiert, wie folgendermaßen dargestellt:
A(in Spalte 1)
A2;20% (Spalte 1;Spalte 2)
A1;10% (Spalte 1;Spalte 2)
A3;5% (Spalte 1;Spalte 2)
B (in Spalte 1)
B1;15% (Spalte 1;Spalte 2)
B4;10% (Spalte 1;Spalte 2)
B2;3% (Spalte 1;Spalte 2)
B3;2% (Spalte 1;Spalte 2)
C (in Spalte 1)
C1;20% (Spalte 1;Spalte 2)
C2;10% (Spalte 1;Spalte 2)
D (in Spalte 1)
D1;10% (Spalte 1;Spalte 2)
Bei nicht vorhandenen Gruppen sollten natürlich auch keine Überschriften angezeigt werden und zwischen den Gruppen dürfen keine Leerzeilen auftreten.
Was sehr wichtig ist, ist dass ich als Ergebnis nur noch wie oben dargestellt zwei Spalten erhalte, in Spalte 1 direkt in der Zelle über A1 die Überschrift A, dann wo B1 beginnt muss sozusagen eine Zeile eingefügt werden mit Überschrift B usw. In Spalte 2 dann die Gewichtung.
Vielen Dank schonmal an alle! Grüße, Eva

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub btest() Dim wks As Worksheet, Zeile1 As Long, ZeileL As Long, Zeile As Long Dim Spalte1 As Integer, Bereich As Range Set wks = ActiveSheet Zeile1 = 1 '1. Zeile der Daten Spalte1 = 1 'Linke Spalte der Daten With wks ZeileL = .Cells(.Rows.Count, Spalte1).End(xlUp).Row Set Bereich = .Range(.Cells(Zeile1, Spalte1), .Cells(ZeileL, Spalte1 + 2)) Bereich.Sort Key1:=Bereich.Range("B1"), order1:=xlAscending, _ Key2:=Bereich.Range("C1"), order2:=xlDescending, Header:=xlNo For Zeile = ZeileL To Zeile1 Step -1 Gruppe = .Cells(Zeile, Spalte1 + 1).Value If Zeile = Zeile1 Then .Cells(Zeile, Spalte1 + 1).ClearContents .Cells(Zeile, Spalte1).Range("A1:C1").Insert Shift:=xlShiftDown .Cells(Zeile, Spalte1).Value = Gruppe Else If .Cells(Zeile, Spalte1 + 1).Value = .Cells(Zeile - 1, Spalte1 + 1).Value Then .Cells(Zeile, Spalte1 + 1).ClearContents Else .Cells(Zeile, Spalte1 + 1).ClearContents .Cells(Zeile, Spalte1).Range("A1:C1").Insert Shift:=xlShiftDown .Cells(Zeile, Spalte1).Value = Gruppe End If End If Next ZeileL = .Cells(.Rows.Count, Spalte1).End(xlUp).Row .Range(.Cells(Zeile1, Spalte1 + 1), .Cells(ZeileL, Spalte1 + 1)).Delete Shift:=xlToLeft End With End Sub

Hallo Eva,
nachdem ich ja schon ein Grundgerüst erstellt hatte hier eine komplette Fassung mit deinen neuen Wünschen.
Im Code muss du noch die Startwerte für Zeilen und Spalten und ggf. die Startzelle für die aufbereiteten Daten anpassen.
Gruß
Franz


Sub btest()
Dim wks As Worksheet, Zeile1 As Long, ZeileL As Long, Zeile As Long
Dim wksZiel As Worksheet, ZielZelle As Range
Dim Spalte1 As Integer, Bereich As Range, SumGruppe As Double
'Basisdaten setzen
Set wks = ActiveSheet
Zeile1 = 20 '1. Zeile der Daten in Quelltabelle
Spalte1 = 4 'Linke Spalte der Daten in Quelltabelle
'Neue Tabelle einfügen
Set wksZiel = Worksheets.Add
wksZiel.Move after:=wks
Set ZielZelle = wksZiel.Range("D20") 'Startzelle für Daten in Zieltabelle
'Bereich mit Daten kopieren
With wks
ZeileL = .Cells(Zeile1, Spalte1).End(xlDown).Row 'hier ggf. festen Wert zuweisen
Set Bereich = .Range(.Cells(Zeile1, Spalte1), .Cells(ZeileL, Spalte1 + 2))
Bereich.Copy Destination:=ZielZelle
End With
With wksZiel
Set Bereich = ZielZelle.Range(Cells(1, 1), Cells(Bereich.Rows.Count, 3))
Spalte1 = ZielZelle.Column
Zeile1 = ZielZelle.Row
'Daten in Zieltabelle nach Gruppen/Prozente sortieren
Bereich.Sort Key1:=Bereich.Range("B1"), order1:=xlAscending, _
Key2:=Bereich.Range("C1"), order2:=xlDescending, Header:=xlNo
'Prozente je Gruppe summieren und Gruppenzeile einfügen
'Bereich wird von unten nach oben abgearbeitet
SumGruppe = 0
For Zeile = Zeile1 + Bereich.Rows.Count - 1 To Zeile1 Step -1
Gruppe = .Cells(Zeile, Spalte1 + 1).Value
If Zeile = Zeile1 Then
.Cells(Zeile, Spalte1 + 1).ClearContents
SumGruppe = SumGruppe + .Cells(Zeile, Spalte1 + 2).Value
.Cells(Zeile, Spalte1).Range("A1:C1").Insert Shift:=xlShiftDown
.Cells(Zeile + 1, Spalte1).Range("A1:C1").Copy
.Cells(Zeile, Spalte1).Range("A1:C1").PasteSpecial Paste:=xlPasteFormats
Application.CutCopyMode = False
.Cells(Zeile, Spalte1).Value = Gruppe
.Cells(Zeile, Spalte1 + 2).Value = SumGruppe
.Cells(Zeile, Spalte1).Range("A1:C1").Font.Bold = True
Else
If .Cells(Zeile, Spalte1 + 1).Value = .Cells(Zeile - 1, Spalte1 + 1).Value Then
.Cells(Zeile, Spalte1 + 1).ClearContents
SumGruppe = SumGruppe + .Cells(Zeile, Spalte1 + 2).Value
Else
.Cells(Zeile, Spalte1 + 1).ClearContents
SumGruppe = SumGruppe + .Cells(Zeile, Spalte1 + 2).Value
.Cells(Zeile, Spalte1).Range("A1:C1").Insert Shift:=xlShiftDown
.Cells(Zeile, Spalte1).Value = Gruppe
.Cells(Zeile, Spalte1 + 2).Value = SumGruppe
.Cells(Zeile, Spalte1).Range("A1:C1").Font.Bold = True
SumGruppe = 0
End If
End If
Next
'Zellen in denen die Gruppen standen löschen
ZeileL = ZielZelle.End(xlDown).Row
.Range(.Cells(Zeile1, Spalte1 + 1), .Cells(ZeileL, Spalte1 + 1)).Delete Shift:=xlToLeft
End With
End Sub

'Daten in Zieltabelle aufbereiten With wksZiel Set Bereich = .Range(ZielZelle, ZielZelle.Offset(Bereich.Rows.Count - 1, 2)) Spalte1 = ZielZelle.Column Zeile1 = ZielZelle.Row 'Inhalte von Zellen entfernen, die scheinbar leer sind oder nur Leerzeichen enthalten For iZeile = 1 To Bereich.Rows.Count For ispalte = 1 To Bereich.Columns.Count If Trim(Bereich(iZeile, ispalte).Value) = "" Then Bereich(iZeile, ispalte).ClearContents End If Next Next 'Daten in Zieltabelle nach Gruppen/Prozente sortieren Bereich.Sort Key1:=Bereich.Range("B1"), order1:=xlAscending, _ Key2:=Bereich.Range("C1"), order2:=xlDescending, Header:=xlNo 'Prozente je strGruppe summieren und Gruppenzeile einfügen 'Bereich wird von unten nach oben abgearbeitet SumGruppe = 0 For Zeile = ZielZelle.End(xlDown).Row To Zeile1 Step -1 strGruppe = .Cells(Zeile, Spalte1 + 1).Value 'Spracheintrag zur Gruppe ermitteln

Beliebteste Forumthreads (12 Monate)

15 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

15
Beiträge zum Forumthread

Beiträge zu diesem Forumthread