|
Sub summary()
Dim rng As Range, rngC As Range
Dim lngCol As Long, Spa_1 As Long, Spa_2 As Long
Dim Spa_W As Variant, Spa_T As Variant
Dim wks As Worksheet
Dim D_T1 As Long, D_T2 As Long, D_W2 As Long, strFormel As String
Dim strMsgTitel As String, strMsg As String, intFehler As Integer
On Error GoTo Fehler
strMsgTitel = "Makro: Summary"
Application.ScreenUpdating = False
With ActiveSheet
intFehler = 1
Set rng = .ListObjects(1).Range
intFehler = 2
'Hilfsspalten setzen
Spa_1 = rng.Column + rng.Columns.Count
Spa_2 = Spa_1 + 1
'Spalte mit "Text" bzw. "Wert" ermitteln
Spa_T = Application.WorksheetFunction.Match("Text", .Rows(1), 0)
Spa_W = Application.WorksheetFunction.Match("Wert", .Rows(1), 0)
.Copy after:=ActiveSheet
End With
Set wks = ActiveSheet
With wks 'ActiveSheet
intFehler = 3
.Name = rng.Parent.Name & " Summary"
intFehler = 4
With .ListObjects(1)
'Prüfen, ob die Tabelle nur aus 1 Datenzeile + der Summenzeile besteht
If .DataBodyRange.Rows.Count = 2 Then GoTo Fehler
If .AutoFilter.FilterMode = True Then .AutoFilter.ShowAllData
End With
intFehler = 5
.Cells(1, Spa_1) = "HS_1"
.Cells(1, Spa_2) = "HS_2"
'Spalten-Differenzen zwischen den Hilfsspalten und den Spalten mit "Text" bzw. "Wert"
D_T1 = Spa_T - Spa_1
D_T2 = Spa_T - Spa_2
D_W2 = Spa_W - Spa_2
strFormel = "=IF(OR(RC[" & D_T1 & "]="""",COUNTIF(R2C[" & D_T1 & "]:RC[" _
& D_T1 & "],RC[" & D_T1 & "])=1),""x"","""")"
.Range(.Cells(2, Spa_1), .Cells(rng.Rows.Count - 1, Spa_1)).FormulaR1C1 = strFormel
strFormel = "=SUMIF(C[" & D_T2 & "]:C[" & D_T2 & "],RC[" & D_T2 & "],C[" _
& D_W2 & "]:C[" & D_W2 & "])"
.Range(.Cells(2, Spa_2), .Cells(rng.Rows.Count - 1, Spa_2)).FormulaR1C1 = strFormel
intFehler = 6
Set rngC = .Columns(Spa_1).SpecialCells(xlCellTypeFormulas)
rngC = rngC.Value
Set rngC = .Columns(Spa_2).SpecialCells(xlCellTypeFormulas)
rngC = rngC.Value
intFehler = 7
For Each rngC In .Range(.Cells(2, Spa_1), .Cells(rng.Rows.Count - 1, Spa_1)) _
.SpecialCells(xlCellTypeConstants).Cells
rngC.Offset(0, Spa_W - Spa_1) = rngC.Offset(0, 1).Value
Next
intFehler = 8
.Cells(1, Spa_1).CurrentRegion.Sort .Cells(1, Spa_1), xlAscending, Header:=xlYes
intFehler = 9
Set rngC = .Range(.Cells(2, Spa_1), .Cells(rng.Rows.Count - 1, Spa_1)) _
.SpecialCells(xlCellTypeBlanks)
If Not rngC Is Nothing Then rngC.EntireRow.Delete
.Columns(Spa_2).Delete
.Columns(Spa_1).Delete
End With
Fehler:
With Err
strMsg = "Fehler-Nr.: " & .Number & " - intFehler = " & intFehler _
& vbLf & .Description
strMsgTitel = strMsgTitel & " - F E H L E R"
Select Case .Number
Case 0 'alles ok
Case 9 'Index-Fehler - Element in Auflistung nicht gefunden
Select Case intFehler
Case 1, 4
MsgBox strMsg & vbLf & vbLf _
& "Keine Tabelle im aktiven Blatt vorhanden!", _
vbOKOnly, strMsgTitel
Case Else
MsgBox strMsg, vbOKOnly, strMsgTitel
End Select
Case 91
'Autofilter in Tabellenobjekt nicht gesetzt
Resume Next
Case 1004
Select Case intFehler
Case 2
MsgBox strMsg & vbLf & vbLf _
& "Spalte ""Text"" oder ""Wert"" nicht gefunden!", _
vbOKOnly, strMsgTitel
Case 3
MsgBox strMsg & vbLf & vbLf _
& "Summary-Blatt ist bereits vorhanden!", _
vbOKOnly, strMsgTitel
'Blatt-Kopie wieder löschen
Application.DisplayAlerts = False
wks.Delete
Application.DisplayAlerts = True
Case 9
'es gibt keine leeren Zellen
Resume Next
Case Else
MsgBox strMsg, vbOKOnly, strMsgTitel
End Select
Case Else
MsgBox strMsg, vbOKOnly, strMsgTitel
End Select
End With
Set wks = Nothing
Set rng = Nothing
Set rngC = Nothing
Application.ScreenUpdating = True
End Sub
|