Sub MaxMin()
Const Zielblatt = "Daten" 'ggfls. anpassen
Const Wertspalte = 3
Dim Ziel As Object, sh As Object, Werte() As Variant
Dim zeile As Long, Wert As String, erg As Variant
Dim ErsteZeile As String, ErgWert As Long, i As Long, anz As Long
Set Ziel = ThisWorkbook.Sheets(Zielblatt)
ReDim Werte(1 To 2, 1 To 1)
For Each sh In ThisWorkbook.Sheets
With sh 'vorhandene Werte ermitteln
zeile = 3
Do
Wert = .Cells(zeile, Wertspalte)
If Wert = "" Then Exit Do
erg = True
For i = 1 To UBound(Werte, 2)
If Wert = Werte(1, i) Then
erg = False
Exit For
End If
Next i
If erg Then 'Wert in Array einfügen
anz = anz + 1
ReDim Preserve Werte(1 To 2, 1 To anz)
Werte(1, anz) = Wert
End If
zeile = zeile + 1
Loop
End With
Next sh
For i = 1 To UBound(Werte, 2) 'Maxima ermitteln
anz = 0
For Each sh In ThisWorkbook.Sheets
With sh
Set erg = sh.Columns(Wertspalte).Find(What:=Werte(1, i), Lookat:=xlWhole)
If Not erg Is Nothing Then
ErsteZeile = erg.Row
Do
anz = anz + 1
Werte(2, i) = WorksheetFunction.Max(Val(Werte(2, i)), Val(sh.Cells(erg.Row, 5)))
Set erg = .Columns(Wertspalte).FindNext(erg)
Loop Until erg.Row = ErsteZeile
End If
End With
Next sh
With Ziel
Set erg = .Columns(Wertspalte).Find(What:=Werte(1, i), Lookat:=xlWhole)
If Not erg Is Nothing Then
.Cells(erg.Row, 6) = IIf(anz = 1, 2, Werte(2, i))
Else
MsgBox "Wert " & Werte(1, i) & " nicht auf Blatt " & Zielblatt & " vorhanden"
End If
End With
Next i
End Sub
Funktioniert bis auf das wenn in der Spalten C im Tabellenblatt Daten keine Doppelten gefunden werden dort ein Spalte F eine 2 Geschrieben wird da sollte eher nichts stehen .
Könnte man das ganze auch ohne das Tabellenblatt Daten machen . Also wie hier mit Tabellenblatt A,B, u.s.w in Spalte F den MAX Wert anzeigen lassen und wenn keine Doppelten gefunden werden Zelle leer lassen.
Benutzer, die gerade dieses Thema anschauen: 3 Gast/Gäste
Hinweis auf Angebot
Excel-Inside - lang Keine
Lösung gefunden? Du kannst Dich gerne an
unser erfahrenes Experten-Team
wenden um dein Anliegen zu besprechen. Gerne
erstellen wir auf dieser Basis ein Angebot. Sende deine Anfrage
einfach per
E-Mail an anfrage@excel-inside.de