Doppelte Werte finden und Max Wert ausgeben

[AlterDresdner]

Hallo Chris,
eine VBA-Lösung wäre

Code:

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