Pivot-Tabelle vorbereiten-0-Summen unterdrücken
21.08.2012 10:06:34
fcs
Hallo Karin,
bereite deine Daten mit dem folgenden Makro auf.
Das sollte nur wenige Sekunden dauern. Ich hab das Makro unter Excel 2010 erstellt. Es sollte aber auch unter älteren Version funktionieren.
Die Werte der Konstanten im Code muss du an den Aufbau deiner Tabelle anpassen.
Gruß
Franz
Sub Umsatz_0_kennzeichnen()
Dim wks As Worksheet
Dim lngZeile As Long, lngZeile1 As Long, lngZeile2 As Long, lngX As Long
Dim strArt As String, strMonat As String, strJaNein As String
Dim dblSumme As Double
Dim StatusCalc As Long
Dim arrData
Const SpalteArt = 1 'Spalte mit Art - hier Spalte A
Const SpalteMonat = 2 'Spalte mit Monat - hier Spalte B
Const SpalteUmsatz = 3 'Spalte mit Umsatz - hier Spalte C
Const SpalteSum0 = 4 'Spalte zur Kennzeichnung Summe 0
Const SpalteRF = 5 'Spalte für temporäre Reihenfolge - Spalterechts von Daten wählen!!
Const ZeileTitel = 1 'Zeile mit den Spaltentiteln
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
On Error GoTo Fehler
Set wks = ActiveSheet
With wks
Application.StatusBar = "Zeilennummern werden eingetragen für spätere Sortierung"
lngZeile1 = ZeileTitel + 1 'Zeile unterhalb Spaltentitel
lngZeile2 = .Cells(.Rows.Count, 1).End(xlUp).Row
'Werte für Reihenfolge temporär eintragen - wird am Ende wieder gelöscht
With .Range(.Cells(lngZeile1, SpalteRF), .Cells(lngZeile2, SpalteRF))
.FormulaR1C1 = "=Row()"
.Calculate
.Value = .Value
End With
'Daten sortieren nach Art und Monat
Application.StatusBar = "Daten werden sortiert nach Art undMonat"
With .Range(.Cells(lngZeile1, 1), .Cells(lngZeile2, SpalteRF))
.Sort key1:=.Cells(1, SpalteArt), Order1:=xlAscending, _
key2:=.Cells(1, SpalteMonat), Order1:=xlAscending, Header:=xlNo
End With
'Summen berechnen/kennzeichnen
arrData = .Range(.Cells(lngZeile1, 1), .Cells(lngZeile2 + 1, SpalteRF))
Application.StatusBar = "Umsätze werden gem. Summe0 gekennzeichnet"
For lngZeile = LBound(arrData, 1) To UBound(arrData, 1)
If strMonat arrData(lngZeile, SpalteMonat) _
Or strArt arrData(lngZeile, SpalteArt) Then
If strMonat "" Then
If Application.WorksheetFunction.Round(dblSumme, 2) = 0 Then
strJaNein = "Nein"
Else
strJaNein = "Ja"
End If
For lngX = lngZeile1 To lngZeile2
arrData(lngX, SpalteSum0) = strJaNein
Next
End If
strMonat = arrData(lngZeile, SpalteMonat)
strArt = arrData(lngZeile, SpalteArt)
lngZeile1 = lngZeile
dblSumme = 0
Application.StatusBar = "Umsätze werden gem. Summe0 gekennzeichnet - Zeile: " & _
lngZeile
End If
lngZeile2 = lngZeile
dblSumme = dblSumme + arrData(lngZeile, SpalteUmsatz)
Next
'Daten aus Array zurückschreiben
lngZeile1 = ZeileTitel + 1 'Zeile unterhalb Spaltentitel
lngZeile2 = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(lngZeile1, 1), .Cells(lngZeile2 + 1, SpalteRF)) = arrData
Erase arrData
Application.StatusBar = "Daten werden sortiert in ursprüngliche Reihenfolge"
'Daten sortieren nach Reihenfolge
lngZeile1 = ZeileTitel + 1 'Zeile unterhalb Spaltentitel
lngZeile2 = .Cells(.Rows.Count, 1).End(xlUp).Row
With .Range(.Cells(lngZeile1, 1), .Cells(lngZeile2, SpalteRF))
.Sort key1:=.Cells(1, SpalteRF), Order1:=xlAscending, Header:=xlNo
End With
'Temporäre Spalte mit Reihenfolge wieder löschen
.Columns(SpalteRF).Clear
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
With Application
.ScreenUpdating = False
.EnableEvents = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.StatusBar = False
End With
End Sub
