Hi gibt es eine Möglichkeit diese Makro so zu ändern das es bei einer gefundenen Untergruppe nicht aussteigt sondern auch meherre Maximale Untergruppen markiert.
Zum gesamten Thema: es Durchsucht in einer Spalte untereinander stehende Gruppen und unter diesen Gruppen unter einer anderne Spalte dann die
UNtergruppe dazu. Es sucht den maximal wert in der Untergruppe und markiert ihn und dann immer so weiter. Leider mnarkiert es mir den maximal
wert nur einmal in der Untergruppe und nicht mehrmals wenn er vorhanden ist.
Option Explicit
Public Sub sort_groups()
Dim l As Long, z As Long
Dim iColGrp As Integer, iColSort As Integer, iColOut As Integer, tmp As Integer
Dim wks As Worksheet
l = 2
iColGrp = 1
iColSort = 2
Set wks = Worksheets("Tabelle1")
With wks
Do While .Cells(l, iColGrp) <> vbNullString And .Cells(l, iColSort) <> vbNullString
tmp = CInt(.Cells(l, iColSort))
z = l
Do While .Cells(z, iColGrp) = .Cells(l, iColGrp)
If .Cells(z, iColSort) > tmp Then
tmp = .Cells(z, iColSort)
End If
z = z + 1
Loop
Call mark_max_group_sort(l, wks, iColGrp, iColSort, CStr(.Cells(l, iColGrp) & tmp))
l = z
Loop
End With
Set wks = Nothing
End Sub
Private Sub mark_max_group_sort(ByVal l As Long, ByRef wks As Worksheet, ByVal iColGrp As Integer, ByVal iColSort As Integer, ByVal sKey As String)
Dim tmp As String
With wks
Do While Not .Cells(l, iColGrp) = vbNullString
tmp = .Cells(l, iColGrp) & .Cells(l, iColSort)
If tmp = sKey Then
.Cells(l, iColSort).Interior.Color = RGB(255, 0, 0)
Exit Sub
End If
l = l + 1
Loop
End With
MsgBox "Schlüssel " & sKey & " nicht gefunden..", vbInformation
End Sub
|