Doppelte Werte finden und Max Wert ausgeben

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