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?
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
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.
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
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
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
Last edited by Zvoni; Jan 24th, 2023 at 05:49 AM.
Last edited by Zvoni; Tomorrow at 31:69 PM.
----------------------------------------------------------------------------------------
One System to rule them all, One Code to find them,
One IDE to bring them all, and to the Framework bind them,
in the Land of Redmond, where the Windows lie
---------------------------------------------------------------------------------
People call me crazy because i'm jumping out of perfectly fine airplanes.
---------------------------------------------------------------------------------
Code is like a joke: If you have to explain it, it's bad
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)
Last edited by Zvoni; Jan 24th, 2023 at 07:29 AM.
Last edited by Zvoni; Tomorrow at 31:69 PM.
----------------------------------------------------------------------------------------
One System to rule them all, One Code to find them,
One IDE to bring them all, and to the Framework bind them,
in the Land of Redmond, where the Windows lie
---------------------------------------------------------------------------------
People call me crazy because i'm jumping out of perfectly fine airplanes.
---------------------------------------------------------------------------------
Code is like a joke: If you have to explain it, it's bad
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
2009 - 2016
Reply With Quote
Originally Posted by Zvoni
