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

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

CodePudding user response：

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