UDF calculation problem

I inherited this UDF.

Code:

---

Public Function GetDouble(v As String) As String
    Dim tmpArr(Limit - 1) As String

    If Len(v) = Limit Then
        tmpArr(0) = Mid(v, 1, 1)
        tmpArr(1) = Mid(v, 2, 1)
        tmpArr(2) = Mid(v, 3, 1)
        tmpArr(3) = Mid(v, 4, 1)

        For i = 0 To Limit - 1 - 1
            For j = i + 1 To Limit - 1
                If tmpArr(i) = tmpArr(j) Then
                    GetDouble = tmpArr(i) & tmpArr(j)
                    Exit Function
                End If
            Next j
        Next i
    End If
    GetDouble = ""
End Function

---

What it does is to look at the cells in a column that contains 4-digit numbers and for each cell it returns the duplicated number twice. For example if a cell contains 2454 it would return 44 and if a cell contains 0999 it would return 99 and if the cell contains something like 1234 it would return a blank. (Strange, I know but that's the requirement.)

The UDF fires any time Excel calculates, and because the worksheet contains 7,000+ rows it takes a very long time. I know that if I set Application.Calculation to xlCalculationManual that that wouldn't happen, but is there any way to avoid having to do that? Would replacing the UDF with an Excel formula help? If so what would that formula be?

Only 4 digit numbers?
Why not create an array for the numbers 0..9999 and fill it once with the double number?

Thanks for the suggestion but it's not that easy. Please see the following picture. The source column is at the right and the desired output is at the left. The source data can change at any time.
Attachment 186725

If there are only the numbers 0..9999 you can create a lookup table instead of calling your method for each cell.

Your picture attachment is only visible for you

I forgot about "Manage Attachments".

Out of curiosity, what gets returned for numbers like:

8484
4848
4488
8844
8448
4884

Also, are the input values always numbers from 0000 - 9999? Or are they 1000-9999? Or some other range?

Also, assuming that 8879 will always return 88, then what Arnoutdv was suggesting was to simply populate an array with the values:

Code:

---

Dim strLookupValues(9999) As String

...
strLookupValues(8779) = "77"
strLookupValues(8879) = "88"
...

---

Then, your function would only need to return the array value for the passed 4 digit number. That would eliminate the nested loops, which should dramatically increase the speed of the process.

Manually entering all of these array values would be cumbersome, but you could actually write "one time use" code that produces the code to populate the array.

And since it appears that, for an input value such as 1234 that the returned String should be empty, then that array value is "for free", in that you don't even need to have a line that gives strLookupValues(1234) a value, since it will be an empty string by default, which appears to be what you would want to return anyway.

Under the assumption that 8484 -> "88", and 8448 -> "88", (basically, the "result" is the first digit, reading from left to right, that has a duplicate).

I wrote some code that produces the array code that populates the values. There's almost 5000 lines of code, which is too long to post in a single reply. If that is the direction you want to go, I'll break it up into 4 separate posts.

I'll just leave this here. This is VB6 code, and I was running into an issue where the output was exceeding the maximum length of a TextBox, so that is why it is split between two textboxes.

When ran, the code will generate lines like:

lv(0) = "00"
lv(1) = "00"
lv(2) = "00"
...
lv(9999) = "99"

Those lines can then be copied/pasted as-is into your Excel VBA code for performance testing.

Note the below code is rough and completely undocumented, get-er-done style.

Code:

---

Private Sub Command1_Click()
  Dim a As Integer
  Dim s As String
  Dim r As String
  Dim fs As String
 
 
  For a = 0 To 7000
    s = ToString(a)
    r = ToShort(s)
    If r <> "" Then
      fs = fs & "lv(" & a & ") = " & Chr(34) & r & Chr(34) & vbCrLf
    End If
  Next a
 
  Text1.Text = fs
 
  fs = ""
  For a = 7001 To 9999
    s = ToString(a)
    r = ToShort(s)
    If r <> "" Then
      fs = fs & "lv(" & a & ") = " & Chr(34) & r & Chr(34) & vbCrLf
    End If
  Next a

  Text2.Text = fs
 
End Sub

Private Function ToString(a As Integer) As String
  If a < 10 Then
    ToString = "000" & Trim(CStr(a))
  ElseIf a < 100 Then
    ToString = "00" & Trim(CStr(a))
  ElseIf a < 1000 Then
    ToString = "0" & Trim(CStr(a))
  Else
    ToString = Trim(CStr(a))
  End If
 
End Function

Private Function ToShort(s As String) As String
  Dim i As Integer
  Dim j As Integer
  Dim c As String
  Dim f As Boolean
 
  ToShort = ""
 
  For i = 1 To 3
    c = Mid(s, i, 1)
    For j = i + 1 To 4
      If c = Mid(s, j, 1) Then
        ToShort = c & c
        f = True
        Exit For
      End If
    Next j
    If f = True Then
      Exit For
    End If
  Next i
 
End Function

---

My take at it with using a buffer array:

Code:

---

Option Explicit

Private m_sDouble(9999) As String
Private m_bInit As Boolean

'<<<< For testing in VB6 IDE
Private Sub Form_Load()
  Dim sDoubleValue As String
 
  Debug.Print "++++++++++++++"
  sDoubleValue = GetDouble(9001)
  sDoubleValue = GetDouble(1234)
  sDoubleValue = GetDouble(8484)
  sDoubleValue = GetDouble(3114)

  sDoubleValue = GetDouble(123)
  sDoubleValue = GetDouble(848)
  sDoubleValue = GetDouble(311)

  sDoubleValue = GetDouble(11)

End Sub
'>>>>

Public Function GetDouble(ByVal sValue As String) As String
  Dim lValue As Long
 
  If Len(sValue) = 0 Then Exit Function
  If Not m_bInit Then pInitDouble
 
  lValue = Val(sValue)
  GetDouble = m_sDouble(lValue)
  Debug.Print sValue, GetDouble
End Function


Private Sub pInitDouble()
  Dim lValue As Long
 
  For lValue = 0 To 9999
    m_sDouble(lValue) = pGetDouble(lValue, True)
  Next lValue
  m_bInit = True
End Sub

Private Function pGetDouble(ByVal lValue As Long, Optional bStopAtFirst As Boolean) As String
  Dim iCnt(9) As Integer, i As Long
  Dim lNextValue As Long, lDec As Long
  Dim sReturn As String
 
  lNextValue = lValue
  Do
    lNextValue = lValue \ 10
    lDec = lValue - (10 * lNextValue)
    iCnt(lDec) = iCnt(lDec) + 1
    If iCnt(lDec) > 1 Then
      sReturn = sReturn & String(iCnt(lDec), Chr$(48 + lDec))
      If bStopAtFirst Then Exit Do
    End If
    lValue = lNextValue
  Loop Until lValue = 0
 
  pGetDouble = sReturn
 
End Function

---

?

Code:

---

Public Function GetDouble(ByVal AString As String) As String
Dim i As Long
Dim c As String
    For i = 1 To Len(AString) - 1 'No need to check the Last Character
        c = Mid$(AString, i, 1)
        If InStr(i + 1, AString, c) Then
            GetDouble = c & c
            Exit For
        End If
    Next
End Function

---

Explanation: There is no need for convoluted nested loops and Arrays.
You're only interested in the first "character" (Digit) which occurs more than 1 time in the Sourcestring.
So, you just run through your Source-String, and check if the current character/digit occurs after the position that character/digit is

e.g. Source="8448"
Get first char = "8"
Check if "8" occurs after its position --> "remaining" Source "448" --> result: Yes --> Exit loop and return that character "doubled"

or

Source = "3227"
First Char = "3"
Check if "3" occurs after its position --> result: No
Next Char = "2"
Check if "2" occurs after its position --> result: Yes --> Exit loop and return that character "doubled"

EDIT: But agreed. A Lookup-Table/Array would be the fastest

Solution with regex (needs Reference to Microsoft VBScript regular Expressions)
I'm only matching digits

Code:

---

Public Function GetDouble(ByVal AString As String) As String
Dim r As RegExp
Dim e As MatchCollection
Dim s As String
    GetDouble = ""                          'Set Result to failure
    Set r = New RegExp                      'Create RegEx-Object
    r.Global = True                        'Must be true
    r.Pattern = "(\d)\d*\1"                'Set the Pattern
    Set e = r.Execute(AString)              'Return Type of Execute is "..As Object" but it's actually MatchCollection
    If e.Count > 0 Then                    'Properties found via Watch-Window
        If e(0).SubMatches.Count > 0 Then
            s = e(0).SubMatches(0)
            GetDouble = s & s
        End If
    End If
End Function

---

No idea about performance (both approaches)

Quote:

---

Originally Posted by Zvoni

No idea about performance (both approaches)

---

Performance of the regex will be abysmal unless cached. The r instance should be cached along with its initialized state (Pattern + Global + compiled execution plan).

Another micro-optimization would be to drop Global=True and loop matches with For Each and the submatches with a second For Each like this

Code:

---

Public Function GetDouble(ByVal AString As String) As String
    Static r        As Object
    Dim oMatch      As Object
    Dim vElem      As Variant
   
    If r Is Nothing Then
        Set r = CreateObject("VBScript.RegExp")
        r.Pattern = "(\d)\d*\1"
    End If
    For Each oMatch In r.Execute(AString)
        For Each vElem In oMatch.SubMatches
            GetDouble = vElem & vElem
            Exit Function
        Next
    Next
End Function

---

cheers,
</wqw>