Excel

Option Explicit

Sub DieDreiHöchstenNumerischenWerteKopieren()
'kopiert die drei höchsten numerischen Werte
'des selektierten Bereichs in die Zwischenablage

Dim zelle As Range
Dim ws As Worksheet 'Merker für aktives Blatt
Dim ws_add As Worksheet 'Hilfsblatt
Dim l_c_add As Long 'Zeilenzähler auf Hilfsblatt
Dim r1 As Range, r2 As Range, r3 As Range
'Spalten auf dem Hilfsblatt
Const c_value = 1
Const c_row = 2
Const c_col = 3

  'Ausgangstabelle merken
  Set ws = ActiveSheet
  
  'Hilfsblatt am Ende anfügen
  ActiveWorkbook.Worksheets.Add After:=Worksheets(Worksheets.Count)
  Set ws_add = Worksheets(Worksheets.Count)
  l_c_add = 0 'Zaehler Zeilen auf dem Hilfsblatt
  
  
  ws.Activate
  'alle selektierten Zelllen untersuchen
  For Each zelle In Selection
    'Zellinhalt numerisch ?
    If ((Not IsEmpty(zelle)) And (IsNumeric(zelle.Value))) Then
      'Wert, Zeile, Spalte der Zelle auf Hilfsblatt merken
      l_c_add = l_c_add + 1
      ws_add.Cells(l_c_add, c_value) = zelle.Value
      ws_add.Cells(l_c_add, c_row) = zelle.Row
      ws_add.Cells(l_c_add, c_col) = zelle.Column
    End If
  Next
  
  'mindestens 3 Werte
  If l_c_add > 2 Then
    'Hilfstabelle nach Wert absteigend sortieren
    ws_add.Activate: ws_add.Cells.Select
    Selection.Sort Key1:=Range(Cells(1, c_value), Cells(1, c_value)), Order1:=xlDescending, _
                  Header:=xlNo, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    
    
    'die drei Zellen mit den höchsten Werten festlegen
    ws.Activate
    Set r1 = ws.Range(Cells(ws_add.Cells(1, c_row), ws_add.Cells(1, c_col)), _
                      Cells(ws_add.Cells(1, c_row), ws_add.Cells(1, c_col)))
    Set r2 = ws.Range(Cells(ws_add.Cells(2, c_row), ws_add.Cells(2, c_col)), _
                      Cells(ws_add.Cells(2, c_row), ws_add.Cells(2, c_col)))
    Set r3 = ws.Range(Cells(ws_add.Cells(3, c_row), ws_add.Cells(3, c_col)), _
                      Cells(ws_add.Cells(3, c_row), ws_add.Cells(3, c_col)))
    
    'Hilfsblatt löschen
    Application.DisplayAlerts = False 'Nachfragen abschalten
    ws_add.Delete
    Application.DisplayAlerts = True
    
    'auf dem Ausgangsblatt die drei höchsten Werte der Selektion neu selektieren
    'und kopieren (zwischenablage)
    ws.Activate
    Union(r1, r2, r3).Select
    Selection.Copy
    
  End If
End Sub