INDEX-Rechnung, Excel-Formel

Option Explicit
Public dteLetzterAufruf As Date
Public Sub Programm()

    Dim letztezeile As Long
    Dim zeilennummern(1 To 100) As Integer
    Dim index As Integer
    Dim indexzeile As Integer
    Dim aehnlichkeit As Variant
    Dim temp As Variant
    Dim vergleich As Variant
    Dim indexzeilenkopieren As Integer
    
    aehnlichkeit = "100"
    index = 1
    
    ThisWorkbook.Sheets("Tabelle1").Range("I4:O100").Value = ""                          'Tabellenbereich auf der rechten Seite löschen
    Range("I4", "O100").Borders.LineStyle = xlNone
    
    letztezeile = ThisWorkbook.Sheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row    'Ermittle die letzte Zeile, in der noch Daten stehen

    
    
    'Finde Zeilen, in denen die höchsten Ähnlichkeiten vorkommen
    Do While aehnlichkeit > 5                                       'Solange die Ähnlichkeit nicht unter 0.05 fällt
                                                                    'gehe abwärts - ausgehend von 1 - iterativ und spaltenweise durch die Tabelle
                                                                    
        For indexzeile = 4 To letztezeile                           'Für jede Zeile
            Set temp = ThisWorkbook.Sheets("Tabelle1").Range("G" & indexzeile)          'Lese den Zelleninhalt als temp ein
            
            If temp * 100 >= aehnlichkeit + 5 Then                     'Prüfe, ob der Wert größer oder gleich der (variablen) Ähnlichkeit ist
                'MsgBox temp
                zeilennummern(index) = indexzeile                   'ist das wahr, speichere die Zeile in ein Array
                index = index + 1                                   'und erhöhe den Arrayindex um 1
            End If
            
            If indexzeile = letztezeile Then                        'Befindet sich die Schleife im letzten Durchlauf, so setze die Ähnlichkeit in 0.05er Schritten nach unten
                aehnlichkeit = aehnlichkeit - 5
            End If
        Next indexzeile
      
        If zeilennummern(1) <> 0 Then                               'Sobald Werte im Array stehen, verlasse die erste Schleife
            Exit Do
        End If
    Loop
    

    'Ergebnisse der obigen Suche auf die rechte Seite kopieren
    For indexzeilenkopieren = 1 To index                            'Für jeden Eintrag im Array
        If zeilennummern(indexzeilenkopieren) <> 0 Then             'für den die Ähnlichkeit ungleich 0 ist
                                                                    'kopiere auf die rechte Seite
            ThisWorkbook.Sheets("Tabelle1").Range("I" & indexzeilenkopieren + 3 & ":O" & indexzeilenkopieren + 3) = ThisWorkbook.Sheets("Tabelle1").Range("A" & zeilennummern(indexzeilenkopieren) & ":G" & zeilennummern(indexzeilenkopieren)).Value
        End If
    Next indexzeilenkopieren
    
    'Formatierung erstellen
    
    Application.ScreenUpdating = False
    ThisWorkbook.Sheets("Tabelle1").Range("A2:G3").Copy                                 'Tabellenkopf kopieren
    ThisWorkbook.Sheets("Tabelle1").Range("I2:O3").PasteSpecial xlPasteAll

    
    ThisWorkbook.Sheets("Tabelle1").Range("I4:O" & index + 2).Select
    
    With ThisWorkbook.Sheets("Tabelle1").Range("I4:O" & index + 2)
        .Borders(xlDiagonalDown).LineStyle = xlNone
        .Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With
    End With
    
    'Sortieren
    ThisWorkbook.Sheets("Tabelle1").Range("I4:O" & index + 2).Select
    Selection.Sort Key1:=Range("O4"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
    
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = False
    SendKeys "{ESC}"
    


End Sub

Sub StarteTimer()
dteLetzterAufruf = Now + TimeValue("00:00:05")
Programm
Application.OnTime dteLetzterAufruf, "StarteTimer"
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

'Application.OnTime dteLetzterAufruf, "StarteTimer", Schedule:=False

End Sub

Private Sub Workbook_Open()
StarteTimer
End Sub