AW: Max Wert
31.01.2014 11:25:39
fcs
Hallo Gregor,
das folgende Makro ermittelt die unter A bis D vorkommenden Werte und trägt sie in Spate G ein. Die von Hajo vorgeschlagene Formel wird dann zur Berechnung der Max-Werte verwendet.
Gruß
Fanz
Sub MakeMaxList_2()
Dim wks As Worksheet
Dim Zei_1 As Long, Zei_L As Long
Dim Spa_1 As Long, Spa_L As Long, Spa_Wert As Long
Dim Spa_AD As Long, Zei_AD As Long
Dim objCol As New Collection
Dim rng_AD As Range, rngZelle As Range
On Error GoTo Fehler
Set wks = ActiveSheet 'Activeworkbook.WorkSheets("Muster")
With wks
'Zeilen und Spaltenwerte setzen/berechnen - Werte ggf. anpassen
Zei_1 = 4 '1. Zeile mit Werten
Zei_L = .Cells(.Rows.Count, 1).End(xlUp).Row 'letzte zeile mit Werten
Spa_1 = 2 'Spalte B - 1. Spalte mit Werten
Spa_L = 5 'Spalte E - letzte Spalte mit Werten
Spa_Wert = Spa_L + 1 ' Spalte F - Spalte mit Längenwerten
Spa_AD = Spa_Wert + 1 'Spalte G - Spalte mit vorkommenden Werten
'alte Ergebnisse löschen
Zei_AD = .Cells(.Rows.Count, Spa_AD).End(xlUp).Row
If Zei_AD >= Zei_1 Then
With .Range(.Cells(Zei_1, Spa_AD), .Cells(Zei_AD, Spa_AD + 1))
.ClearContents
.Offset(1, 0).ClearFormats
End With
End If
'vorhandene Werte in Spalte ABCD eintragen
Set rng_AD = .Range(.Cells(Zei_1, Spa_1), .Cells(Zei_L, Spa_L))
Zei_AD = Zei_1 - 1
For Each rngZelle In rng_AD.Cells
If rngZelle "" Then
objCol.Add Item:=rngZelle.Value, Key:=Str(rngZelle.Value)
Zei_AD = Zei_AD + 1
.Cells(Zei_AD, Spa_AD) = rngZelle.Value
End If
ResumeNextCol:
Next
If Zei_AD > Zei_1 Then
'vorhandene Werte in Spalte ABCD formatieren und sortieren
With .Range(.Cells(Zei_1, Spa_AD), .Cells(Zei_AD, Spa_AD))
.Cells(1, 1).Copy
.PasteSpecial xlPasteFormats
.Sort key1:=.Cells(1, 1), order1:=xlAscending, Header:=xlNo
End With
End If
If Zei_AD >= Zei_1 Then
'Formel zur Berechnung des Max-Wertes einfügen
.Cells(Zei_1, Spa_AD + 1).FormulaArray = "=MAX(IF(" _
& rng_AD.Address(ReferenceStyle:=xlR1C1) & "= RC[-1]," _
& .Range(.Cells(Zei_1, Spa_Wert), .Cells(Zei_L, Spa_Wert)) _
.Address(ReferenceStyle:=xlR1C1) & ",0))"
If Zei_AD > Zei_1 Then
'Formel zur Berechnung der Max-Werte kopieren
.Cells(Zei_1, Spa_AD + 1).Copy .Range(.Cells(Zei_1 + 1, Spa_AD + 1), _
.Cells(Zei_AD, Spa_AD + 1))
End If
'Formeln durch Werte erstzen
With .Range(.Cells(Zei_1, Spa_AD + 1), .Cells(Zei_AD, Spa_AD + 1))
.Value = .Value
End With
End If
End With
Fehler:
With Err
Select Case .Number
Case 0 'alles OK
Case 457 'gleicher Wert soll nochmals der Collection hinzugefügt werden
Resume ResumeNextCol
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbOKOnly, "Fehler Makro-MakeMaxList"
End Select
End With
End Sub