how to optimize my code by eliminating a loop? - excel

Question

sub macro() is for copying values from another sheet and extract only the 2 first words from each cell then comparing all the cells and count the cells that are repeated
I'd like to simplify my code by eliminating a loop it seems like the 3rd loop can be eliminated .
the first loop is for copying values from another sheet and extract only the 2 first words from each cell using the getsummary function.
the second and the third loop is for comparing all the cells then counting the cells that are repeated
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

Answer 1

Try this:
Sub macro()
Dim i As Long, j As Long, var As String, start As Long, finish As Long, countRange As Range, inCache, outCache
start = 7: finish = 2585
var = Application.InputBox(prompt:="nom du sheet")
Sheets.Add.Name = var
If var = "" Then
Exit Sub
Else
inCache = Worksheets("MRT").Cells(start, 5).Resize(finish - start + 1, 1).Value2
outCache = Worksheets(var).Cells(start, 2).Resize(finish - start + 1, 2).Value2
For i = start - 6 To finish - 6
outCache(i, 1) = inCache(i, 1)
outCache(i, 2) = GetSummary(CStr(inCache(i, 1)), 2)
Next i
Worksheets(var).Cells(start, 2).Resize(finish - start + 1, 2).Value2 = outCache
End If
outCache = Worksheets(var).Cells(start, 3).Resize(finish - start + 1, 2).Value2
Set countRange = Worksheets(var).Cells(start, 3).Resize(finish - start + 1)
For j = start - 6 To finish - 6
If outCache(j, 1) = vbNullString Then
outCache(j, 2) = vbNullString
Else
outCache(j, 2) = WorksheetFunction.CountIf(countRange, outCache(j, 1))
End If
Next j
Worksheets(var).Cells(start, 3).Resize(finish - start + 1, 2).Value2 = outCache
End Sub