Как оптимизировать мой код, исключив цикл?

sub macro() предназначен для копирования значений с другого листа и извлечения только двух первых слов из каждой ячейки, затем сравнения всех ячеек и подсчета повторяющихся ячеек. Я хотел бы упростить свой код, устранив цикл, кажется, что третий цикл можно устранить.

первый цикл предназначен для копирования значений с другого листа и извлечения только двух первых слов из каждой ячейки с помощью функции getsummary.

второй и третий цикл предназначены для сравнения всех ячеек, а затем подсчета ячеек, которые повторяются

Public Function GetSummary(text As String, num_of_words As Long) As String
    If (num_of_words <= 0) Then
        GetSummary = ""
        Exit Function
    End If

    Dim words() As String
    words = Split(text, " ")
    
    Dim wordCount As Long
    wordCount = UBound(words) + 1

    Dim result As String

    Dim i As Long
    i = 0
    Do While (i < num_of_words And i < wordCount)
        result = result & " " & words(i)
        i = i + 1
    Loop

    GetSummary = result
End Function

sub macro()
Dim i As Long, j As Long, z As Long, cell As Range, rng As Range, rng2 As Range, A As String, k As Integer, var As String
k = 0
var = Application.InputBox(prompt: = "nom du sheet")
Sheets.Add.Name = var
If var = "" Then
Exit Sub
Else
   For i = 7 To 2585
   Set cell = Worksheets("MRT").Range("E" & i)
   A = cell.Value
     Worksheets(var).Range("C" & i).Value = GetSummary(A, 2)
     Worksheets(var).Range("B" & i) = cell
   Next i
End If
For j = 7 To 2585
    Set rng = Worksheets(var).Range("C" & j)
    If rng = "" Then
    rng.Offset(0, 1) = ""
    Else
    For z = 7 To 2585
      Set rng2 = Worksheets(var).Range("C" & z)
      If rng2 = rng Then
      k = k + 1
      End If
    Next z
    rng.Offset(0, 1) = k
    k = 0
    End If

Next j
End Sub