AW: Funktioniert :-)
16.07.2018 22:54:31
Barbaraa
Mit diesem Code bleiben die Superhelden stehen, der Rest wird gelöscht.
Option Explicit
Sub Gruppenumsatz()
Dim aProduktgruppen 'Liste der Produktgruppen
Dim aBereiche 'Liste der Bereiche
Dim lSpalte As Long 'Datumspalte
Dim lZeile As Long 'Produktzeile
Dim dUmsatz As Double 'Umsatzsummen
Dim lBereich As Long 'Bereich des gröÃten Umsatzes
Dim i As Long, j As Long
aProduktgruppen = Liste(2)
aBereiche = Liste(3)
' aSammlung(Produktgruppe, Bereich)=Umsatz
ReDim asammlung(0 To UBound(aProduktgruppen), 0 To UBound(aBereiche))
For i = 0 To UBound(aProduktgruppen)
asammlung(i, 0) = aProduktgruppen(i)
Next i
For i = 0 To UBound(aBereiche)
asammlung(0, i) = aBereiche(i)
Next i
For lSpalte = 4 To Range("C3").End(xlToRight).Column
' Umsätze löschen
For i = 1 To UBound(asammlung, 1)
For j = 1 To UBound(asammlung, 2)
asammlung(i, j) = 0
Next j
Next i
' Umsatzsummen bilden
For lZeile = 4 To Range("C3").End(xlDown).Row
For i = 1 To UBound(asammlung, 1)
If asammlung(i, 0) = Cells(lZeile, 2) Then
For j = 1 To UBound(asammlung, 2)
If asammlung(0, j) = Cells(lZeile, 3) Then
asammlung(i, j) = asammlung(i, j) + Cells(lZeile, lSpalte)
i = 0
Exit For
End If
Next j
If i = 0 Then Exit For
End If
Next i
Next lZeile
' Umsätze markieren
For i = 1 To UBound(asammlung, 1)
dUmsatz = 0
For j = 1 To UBound(asammlung, 2)
If asammlung(i, j) > dUmsatz Then
dUmsatz = asammlung(i, j)
lBereich = j
End If
Next j
For lZeile = 4 To Range("C3").End(xlDown).Row
If Range("B" & lZeile) = asammlung(i, 0) Then
If Range("C" & lZeile) = asammlung(0, lBereich) Then
' Cells(lZeile, lSpalte).Interior.Color = vbYellow 'Gelb
Else
Cells(lZeile, lSpalte) = "" 'Löschen
End If
End If
Next lZeile
Next i
Next lSpalte
End Sub
Private Function Liste(lSpalte As Long)
Dim i As Long
Dim lZeile As Long
Dim aVerzeichnis
ReDim aVerzeichnis(0)
For lZeile = 4 To Range("C3").End(xlDown).Row
For i = 0 To UBound(aVerzeichnis)
If aVerzeichnis(i) = Cells(lZeile, lSpalte) Then Exit For
Next i
If i > UBound(aVerzeichnis) Then
ReDim Preserve aVerzeichnis(i)
aVerzeichnis(i) = Cells(lZeile, lSpalte)
End If
' lZeile = lZeile + 1
Next lZeile
Liste = aVerzeichnis
End Function
Folgende Erklärung, falls Du es Dir aber doch anders überlegst:
Zwei Zeilen im Code sind extra beschriftet jeweils am Zeilenende: Eine Zeile mit "'Gelb" und eine mit "'Löschen".
Die erste ist für das gelb-Markieren verantwortlich, die andere für das Löschen.
Am Beginn der "'Gelb"-Zeile ist ein kleiner Strich (Apostroph). Das bedeutet, diese Zeile ist auskommentiert, also funktionslos. Es wird also nicht gelb markiert.
Gibst Du das Apostroph weg, wird sie ausgeführt.
Die "'Löschen"-Zeile ist aktiv. Willst Du nun vielleicht doch nicht löschen, setze einfach ein Apostroph davor. Dann bleibt alles stehen.
Jetzt ist alles so eingestellt, wie Du es zuletzt haben wolltest.
Auf die Gesundheit.
LG, Barbara