optimizing code

[fredrerik84]

hi im trying to optimize the following code:

Function VLookLike(txt As String, rng As Range) As String
    Dim temp As String, e, n As Long, a()
    Static RegX As Object
    If RegX Is Nothing Then
        Set RegX = CreateObject("VBScript.RegExp")
        With RegX
            .Global = True
            .IgnoreCase = True
            .Pattern = "(\S+).*" & Chr(2) & ".*\1"
        End With
    End If
    With RegX
        For Each e In rng.Value
            If UCase$(e) = UCase(txt) Then
                VLookLike = e
                Exit For
            End If
            temp = Join$(Array(e, txt), Chr(2))
            If .test(temp) Then
                n = n + 1
                ReDim Preserve a(1 To 2, 1 To n)
                a(2, n) = e
                Do While .test(temp)
                    a(1, n) = a(1, n) + Len(.Execute(temp)(0).submatches(0))
                    temp = Replace(temp, .Execute(temp)(0).submatches(0), "")
                Loop
            End If
        Next
    End With
    If (VLookLike = "") * (n > 0) Then
        With Application
            VLookLike = .HLookup(.Max(.Index(a, 1, 0)), a, 2, False)
        End With
    End If
End Function

so far this is what I got but im stuck :/

Sub VLookLike()
    Dim txt As String
    Dim rng As Variant
    Dim temp As String, e, n As Long, a()
    Static RegX As Object
    Dim Vlook As String
    rng = Range("H" & 2 & ":H" & 1206)
    txt = "Sydney United"
    If RegX Is Nothing Then
        Set RegX = CreateObject("VBScript.RegExp")
        With RegX
            .Global = True
            .IgnoreCase = True
            .Pattern = "(\S+).*" & Chr(2) & ".*\1"
        End With
    End If
    With RegX
        For e = LBound(rng, 1) To UBound(rng, 1)
            If UCase$(e) = UCase(txt) Then
                Vlook = e
                Exit For
            End If
            temp = Join$(Array(e, txt), Chr(2))
            If .test(temp) Then
                n = n + 1
                ReDim Preserve a(1 To 2, 1 To n)
                a(2, n) = e
                Do While .test(temp)
                    a(1, n) = a(1, n) + Len(.Execute(temp)(0).submatches(0))
                    temp = Replace(temp, .Execute(temp)(0).submatches(0), "")
                Loop
            End If
        Next e
    End With
    If (Vlook = "") * (n > 0) Then
        With Application
            Vlook = .HLookup(.Max(.Index(a, 1, 0)), a, 2, False)
        
        End With
    End If
End Sub

if anyone at all have suggestion to help me speed this code up it would be much appreciated

 

[mole999]

are you disabling events, screen updating and calculations prior to running

If you change
rng = Range("H" & 2 & ":H" & 1206) to rng = Range("H2:H" & LastRow) with a suitable last row then it will be more dynamic to the length what needs to be done

 

[fredrerik84]

seams like there are some problems with the foprum today :/ my last post didn't get uploaded ill try again :

- I want to start by thanking you for your help in the other thread I have and also for responding here Ive started this thread as this is a more specific problem and I really need this code to work faster.

are you disabling events, screen updating and calculations prior to running

Normally of course I have an 1row var set , but this is just in a testing sheet that does not work yet. And I have not tried the original function by disabling events, screen updating and calculations.

I'm not really sure what that is missing from the edited code. from what that I can tell the array is set correctly and it loops trough it lightning fast. But the text string which is set to "Sydney United" does not return any suggestions after looping trough my list.

Do you see what im missing ?

Also if you are interested ill include my test sheet

<a href=http://www.filedropper.com/testbook3><img src=http://www.filedropper.com/download_button.png width=127 height=145 border=0/></a><br /><div style=font-size:9px;font-family:Arial, Helvetica, sans-serif;width:127px;font-color:#44a854;> <a href=http://www.filedropper.com >share files free</a></div>

 

[fredrerik84]

still stuck with this problem , anyone else have a suggestion?