Possible with a faster code?

[fredrerik84]

I have a big problem where im trying to look for similarities and I just built a working code however its way to slow :/ I thought maybe the Similarity function I call was the bottleneck but just writing a simple "1" to each of these cells also took quite awhile

Sub FindSimilarity()
Dim lr As Long, i As Long, j As Long
Dim vData As Variant
Dim str As String, str2 As String
Dim sheet As Worksheet
Set sheet = ActiveWorkbook.Sheets("Sheet1")
j = 2
lr = sheet.Cells(Rows.Count, "H").End(xlUp).Row
vData = sheet.Range("H2:H" & lr)




   For i = LBound(vData, 1) To UBound(vData, 1)
      m = 0
      str = vData(i, 1)
      If Not IsNull(str) Then
      
         For j = LBound(vData, 1) To UBound(vData, 1)
            str2 = vData(j, 1)
               If Not IsNull(str2) Then
                  Cells(i + 1, 13 + j).Value = Similarity(str, str2)
               End If
         Next j
      End If
   Next i
End Sub

Basically this code writes to about 1000 columns x 1000 rows .. Is there a better way to speed this code up ? was thinking to add all off this into another array ?
I don't need all off this data Just str , str2 and the highest value of each row..

This was a little crazy code as it takes over 5 min to complete on my system

 

[fredrerik84]

Updated code. with calcualtion turned of ., much better but still to slow :/