I have recently created a macro that uses a lot of large (like over 100 digits in decimal) numbers. To handle them, I scraped around the internet for ideas and optimized a lot of the stuff I found to meet my requirements.
However, I found a large number multiplication function that works... but seems to me as not to be too efficient.
I tried to think up my own algo from scratch, and I tried to optimize this one... but I can't seem to get it any faster.
I was trying to think of a method that wouldn't require factorOneNbr to reference LargeMult... but got nothing.
If anyone has any pointers I would appreciate it.
Thanks!
Here's the code:
Public Sub Initialize()
Static Initialized As Boolean
If Initialized Then Exit Sub
Initialized = True
cDecMax = _
CDec(Replace("79,228,162,514,264,337,593,543,950,335", ",", ""))
'this is 2^96-1
cDecMaxLen = Len(cDecMax) - 1
cSqrDecMaxLen = cDecMaxLen \ 2
End Sub
Function Ceil(x As Single) As Long
If x < 0 Then Ceil = Fix(x) Else Ceil = -Int(-x)
End Function
Function LargeMult(ByVal Nbr1 As String, ByVal Nbr2 As String) As String
Initialize
Dim negative As Boolean
negative = False
If Left(Nbr1, 1) = "-" And Left(Nbr2, 1) = "-" Then
Nbr1 = Right(Nbr1, Len(Nbr1) - 1)
Nbr2 = Right(Nbr2, Len(Nbr2) - 1)
ElseIf Left(Nbr1, 1) = "-" Then
Nbr1 = Right(Nbr1, Len(Nbr1) - 1)
negative = True
ElseIf Left(Nbr2, 1) = "-" Then
Nbr2 = Right(Nbr2, Len(Nbr2) - 1)
negative = True
End If
If Len(Nbr1) <= cSqrDecMaxLen And Len(Nbr2) <= cSqrDecMaxLen Then
LargeMult = CStr(CDec(Nbr1) * CDec(Nbr2))
If negative Then LargeMult = "-" & LargeMult
Exit Function
End If
If Len(Nbr1) > cSqrDecMaxLen Then
LargeMult = factorOneNbr(Nbr1, Nbr2)
Else
LargeMult = factorOneNbr(Nbr2, Nbr1)
End If
If negative Then LargeMult = "-" & LargeMult
End Function
Private Function factorOneNbr(ByVal LargeNbr As String, _
ByVal Nbr2 As String) As String
Dim NbrChunks As Integer, i As Integer, _
Nbr1Part As String, PowersOf10 As Integer, _
Rslt As String, FinalRslt As String
FinalRslt = "0"
NbrChunks = Ceil(Len(LargeNbr) / cSqrDecMaxLen) - 1
For i = NbrChunks To 0 Step -1
Nbr1Part = Mid(LargeNbr, i * cSqrDecMaxLen + 1, cSqrDecMaxLen)
Rslt = LargeMult(Nbr1Part, Nbr2)
FinalRslt = LargeAdd(FinalRslt, Rslt & String(PowersOf10, "0"))
PowersOf10 = PowersOf10 + Len(Nbr1Part)
Next i
factorOneNbr = FinalRslt
End Function
Related
This is my code to get right side of string specifying char separator and either to keep separator within string or not. Possibility also to specify if just last occurence of char separator or manually define it. My question is how to make same version but this time to get right side of string instead of left?
Public Shared Function GetLetSideStringByChar(splitterChar As String, searchingWord As String, keepCharAsWell As Boolean, lastindexof As Boolean, splitterCharPosition As Integer) As String
Dim index As Integer
Select Case lastindexof
Case False
index = GetNthIndex(searchingWord, splitterChar, splitterCharPosition)
Case True
index = searchingWord.LastIndexOf(splitterChar)
End Select
If index > 0 Then
If keepCharAsWell Then
searchingWord = searchingWord.Substring(0, index + splitterChar.Length)
Else
searchingWord = searchingWord.Substring(0, index)
End If
Else
searchingWord = String.Empty
End If
Return searchingWord
End Function
'jesli n separator nie odnalzeiony bedzie return -1, np jesli charseparator = . i damy n = 2 a word bedzie mial tlko jedna . to -1
Public Shared Function GetNthIndex(searchingWord As String, charseparator As Char, n As Integer) As Integer
Dim count As Integer = 0
For i As Integer = 0 To searchingWord.Length - 1
If searchingWord(i) = charseparator Then
count += 1
If count = n Then
Return i
End If
End If
Next
Return -1
End Function
I had written a code for your previous problem that you deleted.
To make the code more understandable I used an Enum to specify right or left:
Public Enum Direction
Left = 0
Right = 1
End Enum
then you can call the function like this:
Console.WriteLine(StringExtract("5345.342.323.323#$%", Direction.Right, 2, False))
Here the Seperator Index represents the dot number (starting at 1)
For Example:
648674.2327.12 first dot is 1 second is 2
And here is the function, I'm sure it could be shortened:
Public Function StringExtract(ByVal MyStr As String, ByVal Side As Direction, ByVal SeperatorIndex As Integer, ByVal SeperatorKeep As Boolean) As String
Dim MySubs() As String = MyStr.Split(".".ToCharArray, StringSplitOptions.RemoveEmptyEntries)
Dim IndexOfSplit As Integer
Dim MyResult As String = ""
If Side = Direction.Left Then
IndexOfSplit = SeperatorIndex - 1
For i As Integer = IndexOfSplit To 0 Step -1
MyResult = MyResult.Insert(0, MySubs(i) & ".")
Next
If SeperatorKeep = False Then
MyResult = MyResult.Remove(MyResult.LastIndexOf("."), 1)
End If
Else
IndexOfSplit = SeperatorIndex
For i As Integer = IndexOfSplit To MySubs.Length - 1
MyResult = MyResult & MySubs(i) & "."
Next
If SeperatorKeep = False Then
MyResult = MyResult.Remove(MyResult.LastIndexOf("."), 1)
Else
MyResult = "." & MyResult.Remove(MyResult.LastIndexOf("."), 1)
End If
End If
Return MyResult
End Function
Output example:
Input 1:
StringExtract("5345.342.323.323#$%", Direction.Right, 2, False)
Output 1:
323.323#$%
Input 2:
StringExtract("5345.342.323.323#$%", Direction.Right, 3, True)
Output 2:
.323#$%
Input 3:
StringExtract("4.34!2.3323.", Direction.Left, 2, True)
Output 3:
4.34!2.
PS: If anyone has any suggestions to shorten the function let me know I'm happy to learn.
I have written a UDF in VBA that takes a parameter and a string and processes them to return a double. I would like to be able to use this formula to process a column of a table for a range in a sumproduct formula and I'm having some issues.
Public Function ColorCount(Color As String, ToCount As String)
Dim WordArray() As String
ToCount = Replace(ToCount, " ", "")
WordArray() = Split(ToCount, "}{")
ColorCount = 0
For i = LBound(WordArray) To UBound(WordArray)
WordArray(i) = Replace(WordArray(i), "{", "")
WordArray(i) = Replace(WordArray(i), "}", "")
If UCase(Color) = UCase(WordArray(i)) Then
ColorCount = ColorCount + 1
ElseIf UCase(WordArray(i)) Like UCase(Color) & "[/\]*" Or UCase(WordArray(i)) Like "*[/\]" & UCase(Color) Then
ColorCount = ColorCount + 0.5
End If
Next i
End Function
I have data in a table that I would like to be able to call for a sum product. I've tried something similar to =sumproduct(Table[Quant],ColorCount("Color", Table[Colors]) but it doesn't seem to work.
Any advice or help would be appreciated!
Write all the processing into the UDF. It seems a shame not to take advantage of the superior (compared to SUMPRODUCT) looping available in VBA.
Option Explicit
Public Function udfColorCount(theColor As String, toCount As Range, toQty As Range)
Dim c As Integer, i As Integer, colorString As String, colorArray As Variant
'toCount = Replace(toCount, " ", vbNullString)
udfColorCount = 0
For c = 1 To toQty.Cells.Count
Debug.Print toCount.Cells(c).Value2
colorString = Replace(toCount.Cells(c).Value2, Chr(32), vbNullString)
colorArray = Split(Mid(colorString, 2, Len(colorString) - 2), "}{")
For i = LBound(colorArray) To UBound(colorArray)
If UCase(theColor) = UCase(colorArray(i)) Then
udfColorCount = udfColorCount + toQty.Cells(c)
ElseIf CBool(InStr(1, colorArray(i), theColor, vbTextCompare)) Then
udfColorCount = udfColorCount + 0.5 * toQty.Cells(c)
End If
Next i
Next c
End Function
I am developing an application in visual basic 2010, that finds the memory usage of a particular process. I came across this code:
Option Explicit
Private Sub Command1_Click()
Debug.Print GetProcessMemory("vb6.exe")
End Sub
Private Function GetProcessMemory(ByVal app_name As String) As String
Dim Process As Object
Dim dMemory As Double
For Each Process In GetObject("winmgmts:").ExecQuery("Select WorkingSetSize from Win32_Process Where Name = '" & app_name & "'")
dMemory = Process.WorkingSetSize
Next
If dMemory > 0 Then
GetProcessMemory = ResizeKb(dMemory)
Else
GetProcessMemory = "0 Bytes"
End If
End Function
Private Function ResizeKb(ByVal b As Double) As String
Dim bSize(8) As String, i As Integer
bSize(0) = "Bytes"
bSize(1) = "KB" 'Kilobytes
bSize(2) = "MB" 'Megabytes
bSize(3) = "GB" 'Gigabytes
bSize(4) = "TB" 'Terabytes
bSize(5) = "PB" 'Petabytes
bSize(6) = "EB" 'Exabytes
bSize(7) = "ZB" 'Zettabytes
bSize(8) = "YB" 'Yottabytes
For i = UBound(bSize) To 0 Step -1
If b >= (1024 ^ i) Then
ResizeKb = ThreeNonZeroDigits(b / (1024 ^ _
i)) & " " & bSize(i)
Exit For
End If
Next
End Function
Private Function ThreeNonZeroDigits(ByVal value As Double) As Double
If value >= 100 Then
ThreeNonZeroDigits = FormatNumber(value)
ElseIf value >= 10 Then
ThreeNonZeroDigits = FormatNumber(value, 1)
Else
ThreeNonZeroDigits = FormatNumber(value, 2)
End If
End Function
but this does not work in vb2010. It returns 0bytes. Please help. Alternative techniques are also appreciated.
Which are the combinations that the sum of each digit is equal to 8 or less, from 1 to 88,888,888?
For example,
70000001 = 7+0+0+0+0+0+0+1 = 8 Should be on the list
00000021 = 0+0+0+0+0+0+2+1 = 3 Should be on the list.
20005002 = 2+0+0+0+5+0+0+2 = 9 Should not be on the list.
Sub Comb()
Dim r As Integer 'Row (to store the number)
Dim i As Integer 'Range
r = 1
For i = 0 To 88888888
If i = 8
'How can I get the sum of the digits on vba?
ActiveSheet.Cells(r, 1) = i
r = r + 1
End If
Else
End Sub
... Is this what you're looking for?
Function AddDigits(sNum As String) As Integer
Dim i As Integer
AddDigits = 0
For i = 1 To Len(sNum)
AddDigits = AddDigits + CInt(Mid(sNum, i, 1))
Next i
End Function
(Just remember to use CStr() on the number you pass into the function.
If not, can you explain what it is you want in a bit more detail.
Hope this helps
The method you suggest is pretty much brute force. On my machine, it ran 6.5min to calculate all numbers. so far a challenge I tried to find a more efficient algorithm.
This one takes about 0.5s:
Private Const cIntNumberOfDigits As Integer = 9
Private mStrNum As String
Private mRng As Range
Private Sub GetNumbers()
Dim dblStart As Double
Set mRng = Range("a1")
dblStart = Timer
mStrNum = Replace(Space(cIntNumberOfDigits), " ", "0")
subGetNumbers 8
Debug.Print (Timer - dblStart) / 10000000, (Timer - dblStart)
End Sub
Private Sub subGetNumbers(intMaxSum As Integer, Optional intStartPos As Integer = 1)
Dim i As Integer
If intStartPos = cIntNumberOfDigits Then
Mid(mStrNum, intStartPos, 1) = intMaxSum
mRng.Value = Val(mStrNum)
Set mRng = mRng.Offset(1)
Mid(mStrNum, intStartPos, 1) = 0
Exit Sub
End If
For i = 0 To intMaxSum
Mid(mStrNum, intStartPos, 1) = CStr(i)
subGetNumbers intMaxSum - i, intStartPos + 1
Next i
Mid(mStrNum, intStartPos, 1) = 0
End Sub
It can be sped up further by about factor 10 by using arrays instead of writing directly to the range and offsetting it, but that should suffice for now! :-)
As an alternative, You can use a function like this:
Function isInnerLowr8(x As Long) As Boolean
Dim strX As String, inSum As Long
isInnerLowr8 = False
strX = Replace(CStr(x), "0", "")
For i = 1 To Len(strX)
Sum = Sum + Val(Mid(strX, i, 1))
If Sum > 8 Then Exit Function
Next i
isInnerLowr8 = True
End Function
Now change If i = 8 to If isInnerLowr8(i) Then.
I have string "ololo123".
I need get position of first digit - 1.
How to set mask of search ?
Here is a lightweight and fast method that avoids regex/reference additions, thus helping with overhead and transportability should that be an advantage.
Public Function GetNumLoc(xValue As String) As Integer
For GetNumLoc = 1 To Len(xValue)
If Mid(xValue, GetNumLoc, 1) Like "#" Then Exit Function
Next
GetNumLoc = 0
End Function
Something like this should do the trick for you:
Public Function GetPositionOfFirstNumericCharacter(ByVal s As String) As Integer
For i = 1 To Len(s)
Dim currentCharacter As String
currentCharacter = Mid(s, i, 1)
If IsNumeric(currentCharacter) = True Then
GetPositionOfFirstNumericCharacter = i
Exit Function
End If
Next i
End Function
You can then call it like this:
Dim iPosition as Integer
iPosition = GetPositionOfFirstNumericCharacter("ololo123")
Not sure on your environment, but this worked in Excel 2010
'Added reference for Microsoft VBScript Regular Expressions 5.5
Const myString As String = "ololo123"
Dim regex As New RegExp
Dim regmatch As MatchCollection
regex.Pattern = "\d"
Set regmatch = regex.Execute(myString)
MsgBox (regmatch.Item(0).FirstIndex) ' Outputs 5
I actually have that function:
Public Function GetNumericPosition(ByVal s As String) As Integer
Dim result As Integer
Dim i As Integer
Dim ii As Integer
result = -1
ii = Len(s)
For i = 1 To ii
If IsNumeric(Mid$(s, i, 1)) Then
result = i
Exit For
End If
Next
GetNumericPosition = result
End Function
You could try regex, and then you'd have two problems. My VBAfu is not up to snuff, but I'll give it a go:
Function FirstDigit(strData As String) As Integer
Dim RE As Object REMatches As Object
Set RE = CreateObject("vbscript.regexp")
With RE
.Pattern = "[0-9]"
End With
Set REMatches = RE.Execute(strData)
FirstDigit = REMatches(0).FirstIndex
End Function
Then you just call it with FirstDigit("ololo123").
If speed is an issue, this will run a bit faster than Robs (noi Rob):
Public Sub Example()
Const myString As String = "ololo123"
Dim position As Long
position = GetFirstNumeric(myString)
If position > 0 Then
MsgBox "Found numeric at postion " & position & "."
Else
MsgBox "Numeric not found."
End If
End Sub
Public Function GetFirstNumeric(ByVal value As String) As Long
Dim i As Long
Dim bytValue() As Byte
Dim lngRtnVal As Long
bytValue = value
For i = 0 To UBound(bytValue) Step 2
Select Case bytValue(i)
Case vbKey0 To vbKey9
If bytValue(i + 1) = 0 Then
lngRtnVal = (i \ 2) + 1
Exit For
End If
End Select
Next
GetFirstNumeric = lngRtnVal
End Function
An improved version of spere's answer (can't edit his answer), which works for any pattern
Private Function GetNumLoc(textValue As String, pattern As String) As Integer
For GetNumLoc = 1 To (Len(textValue) - Len(pattern) + 1)
If Mid(textValue, GetNumLoc, Len(pattern)) Like pattern Then Exit Function
Next
GetNumLoc = 0
End Function
To get the pattern value you can use this:
Private Function GetTextByPattern(textValue As String, pattern As String) As String
Dim NumLoc As Integer
For NumLoc = 1 To (Len(textValue) - Len(pattern) + 1)
If Mid(textValue, NumLoc, Len(pattern)) Like pattern Then
GetTextByPattern = Mid(textValue, NumLoc, Len(pattern))
Exit Function
End If
Next
GetTextByPattern = ""
End Function
Example use:
dim bill as String
bill = "BILLNUMBER 2202/1132/1 PT2200136"
Debug.Print GetNumLoc(bill , "PT#######")
'Printed result:
'24
Debug.Print GetTextByPattern(bill , "PT#######")
'Printed result:
'PT2200136