Help to speed up UDF (if is possible)

[davidmg1982]

Hi all, its my first day at work and par of it is to run a formula based on a UDF, which search for a value within a cell text string based on a column list, this list is almost 25000 rows. Since its searching for this many words in almost 35000 text strings, it takes about 40 min, which is honestly fine for the amount of work, but i would appreciate if any of you kind people take a look and sugest any posible improvement to the function to speed the process. Thanks in advance for your kind help.

Example of the formula since i cannot attach an example doc.
B2=ExtractServer(A2,Sheet2!$A$1:$A$22804)

Function ExtractServer(SearchRange As Range, DogRange As Range) As String
 For Each Myrange In DogRange
  If InStr(1, SearchRange.Value, Myrange) > 0 Then ExtractServer = Myrange
 Next
End Function

 

[davidmg1982]

Give this macro a try... I believe it will do what you want. It fills Column J with either the server name when Column D has the word "Servers" in it or from the DOGRANGE sheet if one of the names on the DOGRANGE sheet exists in the description (sometimes there is no match, so the Column J cell remains blank for them). This code also list multiple servers when more than one name exists on the DOGRANGE sheet. And best of all, the entire list in Column J was generated in about 5 minutes on my computer (your computer's timing will more than likely vary).

[TABLE="width: 500"]
<tbody>[TR]
[TD]Sub ExtractServerSubroutine()
  Dim X As Long, MinLen As Long, Dogs As String, Data As Variant, Servers As Variant, Result As Variant, W As Variant
  Dogs = " " & Join(Application.Transpose(Sheets("DOGRANGE").Range("A2", Sheets("DOGRANGE").Cells(Rows.Count, "A").End(xlUp)))) & " "
  With Sheets("SEARCHNAMES")
    Data = .Range("I2", .Cells(Rows.Count, "I").End(xlUp))
    Servers = .Range("D2", .Cells(Rows.Count, "D").End(xlUp).Resize(, 5))
  End With
  MinLen = Evaluate("MIN(LEN(DOGRANGE!A2:A" & Sheets("DOGRANGE").Cells(Rows.Count, "A").End(xlUp).Row & "))")
  ReDim Result(1 To UBound(Data), 1 To 1)
  For X = 1 To UBound(Data)
    If Servers(X, 1) = "Servers" Then
      Result(X, 1) = Servers(X, 5)
    Else
      For Each W In Split(Data(X, 1))
        If Len(W) >= MinLen Then
          If InStr(1, Dogs, " " & W & " ", vbTextCompare) Then
            Result(X, 1) = Result(X, 1) & ", " & W
            If Left(Result(X, 1), 1) = "," Then Result(X, 1) = Mid(Result(X, 1), 3)
          End If
        End If
      Next
    End If
  Next
  Range("J2").Resize(UBound(Result)) = Result
End Sub
[/TD]
[/TR]
</tbody>[/TABLE]

Rick, probably my computer is not that powerful, but still it was run in less than 10 minutes which is amazing, I have no words, its working and delivering. Thank you so much.

 

[Rick Rothstein]

Rick, probably my computer is not that powerful, but still it was run in less than 10 minutes which is amazing, I have no words, its working and delivering. Thank you so much.

You are quite welcome. Once I was able to see your actual data, I realized that most of the "words" in the description being checked were too short to have been a server name, so I put in a test to eliminate looking at those short "words"... this save a lot of time. I implemented a couple of other things to help speed things up even more. Overall, it looks like the code ended up saving you more than 30 minutes wait time... I am glad you are satisfied with that.