Tabelle Zusammenfassen dynamisch
11.06.2015 22:27:16
Eda
Ich bin gerade dabei ein Makro zu erstellen für die Zusammenfassung einer Tabelle. Der Code (Vielen Dank an Sepp) funktioniert ziemlich gut; nur leider ist sie nicht wirklich dynamisch. Zurzeit geht sie leider immer nur fix die Spalte F durch und addiert bei einem doppeltem Eintrag in Spalte E in der gleichen Zeile die Werte.
Nun hab ich das Problem dass "Text" und "Wert" nicht immer in Spalte F und G sind. Es könnten Tabellen geben in denen sie in einer anderen Spalte stehen. Deswegen muss ich den Code so verändern, dass er erstmal herausfindet in welcher Spalte sich "Text" und "Wert" befindet und dementsprechend vorangeht und genau da hab ich Probleme.
Im Anhang ist nochmal eine Beispieldatei mit entsprechendem Makro für die Zusammenfassung.
Würde mich über Hilfe sehr freuen :)
https://www.herber.de/bbs/user/98154.xlsm
gleich mit Makro :)
Code:
Option Explicit
Sub summary()
Dim rng As Range, rngC As Range
Dim lngCol As Long
On Error Resume Next
Application.ScreenUpdating = False
With ActiveSheet
Set rng = .ListObjects(1).Range
If rng Is Nothing Then Exit Sub
.Copy after:=ActiveSheet
End With
With ActiveSheet
.Name = rng.Parent.Name & " Summary"
If .AutoFilterMode Then .ShowAllData
.Range(.Cells(1, 7), .Cells(1, 8)) = "XXX"
.Range(.Cells(2, 7), .Cells(rng.Rows.Count - 1, 7)).Formula = "=IF(OR(F2="""",COUNTIF($F$2:F2, _
_
F2)=1),""x"","""")"
.Range(.Cells(2, 8), .Cells(rng.Rows.Count - 1, 8)).Formula = "=SUMIF(F:F,F2,E:E)"
Set rngC = .Columns(7).SpecialCells(xlCellTypeFormulas)
rngC = rngC.Value
Set rngC = .Columns(8).SpecialCells(xlCellTypeFormulas)
rngC = rngC.Value
For Each rngC In .Range(.Cells(2, 7), .Cells(rng.Rows.Count - 1, 7)).SpecialCells( _
xlCellTypeConstants)
rngC.Offset(0, -2) = rngC.Offset(0, 1).Value
Next
.Cells(1, 7).CurrentRegion.Sort .Cells(1, 7), xlAscending, Header:=xlYes
Set rngC = .Range(.Cells(2, 7), .Cells(rng.Rows.Count - 1, 7)).SpecialCells(xlCellTypeBlanks)
If Not rngC Is Nothing Then rngC.EntireRow.Delete
.Columns(8).Delete
.Columns(7).Delete
End With
Application.ScreenUpdating = True
Set rng = Nothing
Set rngC = Nothing
End Sub
Eda