Speed up VBA code which compares parts of strings in multiple cells-CodePudding

Below code takes more than one hours to complete if sheet contains 2000 rows. I am unable to convert in array. I think if I can convert this into array will be much faster.

Sub CompareAndCopy()

Dim NumberOfValues, NumberOfValues2 As Integer
Dim value1, value2 As String
Dim value3 As Long
Dim i, n, j As Long

j = 2

Sheet1.Activate
NumberOfValues = Sheets("Sheet1").Range("M2").End(xlDown).Row
NumberOfValues2 = Sheets("Sheet1").Range("A2").End(xlDown).Row
For i = 1 To NumberOfValues
    value3 = 0
    For n = 1 To NumberOfValues2`enter code here`
        value1 = LCase(Range("A" & n).Value)
        value2 = LCase(Range("M" & i).Value)
        If Mid(value1, 1, Len(value2)) = value2 Then
            value3 = value3   Range("C" & n).Value
            Range("T" & i).Value = value3
        End If
        Sheet1.Activate
        j = j   1
    Next
Sheet1.Activate
Next

End Sub

CodePudding user response：

Include Application.Calculation = xlManual before the loops, and
Application.Calculation = xlAutomatic after the loops.
And as others suggested, remove those those useless Activate.

CodePudding user response：

Is this correct code would be ?

Sub CompareAndCopy()

Dim NumberOfValues, NumberOfValues2 As Integer
Dim value1, value2 As String
Dim value3 As Long
Dim i, n, j As Long

NumberOfValues = Sheets("Sheet1").Range("M2").End(xlDown).Row
NumberOfValues2 = Sheets("Sheet1").Range("A2").End(xlDown).Row
Application.Calculation = xlManual
For i = 1 To NumberOfValues
    value3 = 0
    Application.Calculation = xlManual
    For n = 1 To NumberOfValues2`enter code here`
        value1 = LCase(Range("A" & n).Value)
        value2 = LCase(Range("M" & i).Value)
        If Mid(value1, 1, Len(value2)) = value2 Then
            value3 = value3   Range("C" & n).Value
            Range("T" & i).Value = value3
        End If
      
    Next
Application.Calculation = xlAutomatic
Next
Application.Calculation = xlAutomatic