Converting VERY large number to a hex string - vb6

Public Function MyMod(a As Double, b As Double) As Double
MyMod = a - Int(a / b) * b
End Function
This code doesn't work as it doesn't correctly show the remainder do be able to then calculate HEX.
Correct : 10009335357561071 / 16 = 62558345984756.69
VB6 MyMod returns 0 instead of a valid remainder.
I have been unable to figure out how to convert such a large value into a hex string?

I was able to code it myself. Because of the vb6 limitations of the size of a number, I had to go about it in different ways. I needed this to be able to covert VERY LARGE WHOLE numbers to Binary and Hexadecimal.
This this code, there are three functions you can use.
1) Decimal 2 Hex
2) Binary to Hex
3) Decimal 2 Binary
The code works and gives me CORRECT returns for the VERY large numbers.
Public Function Dec2Hex(Dec As String) As String
Dec2Hex = Binary2Hex(Dec2Bin(Dec))
End Function
Public Function Binary2Hex(Binary As String, Optional Pos As Long = 0) As String
Dim tic As Long
Dim Sz As Long
Dim x As Long
Dim z As Long
Dim AT As Long
Dim Hx As Long
Dim HxB As String
Dim xstart As Long
Dim xstop As Long
HxB = vbNullString
If InStrB(Binary, " ") <> 0 Then Binary = Replace(Binary, " ", "")
Sz = Len(Binary)
xstart = Sz
xstop = xstart - 3
Do
AT = 0
Hx = 0
If xstop < 1 Then xstop = 1
For x = xstart To xstop Step -1
AT = AT + 1
If AscB(Mid$(Binary, x, 1)) = 49 Then
Select Case AT
Case 1: Hx = Hx + 1
Case 2: Hx = Hx + 2
Case 3: Hx = Hx + 4
Case 4: Hx = Hx + 8
End Select
End If
Next x
HxB = Digit2Hex(CStr(Hx)) + HxB
If x <= 1 Then Exit Do
xstart = x
xstop = xstart - 3
Loop
Binary2Hex = HxB
End Function
Private Function Digit2Hex(digit As String) As String
Select Case digit
Case "0": Digit2Hex = "0"
Case "1": Digit2Hex = "1"
Case "2": Digit2Hex = "2"
Case "3": Digit2Hex = "3"
Case "4": Digit2Hex = "4"
Case "5": Digit2Hex = "5"
Case "6": Digit2Hex = "6"
Case "7": Digit2Hex = "7"
Case "8": Digit2Hex = "8"
Case "9": Digit2Hex = "9"
Case "10": Digit2Hex = "A"
Case "11": Digit2Hex = "B"
Case "12": Digit2Hex = "C"
Case "13": Digit2Hex = "D"
Case "14": Digit2Hex = "E"
Case "15": Digit2Hex = "F"
Case Else: Digit2Hex = vbNullString
End Select
End Function
Public Function Dec2Bin(Dec As String) As String
Dim Bin As String
Dim Var As Variant
Dim p As Long
Dim Tmp As String
Bin = vbNullString
Tmp = Dec
Do
Bin = IIf(isEven(Tmp), "0", "1") + Bin
Var = CDec(Tmp)
Var = Var / 2
Tmp = CStr(Var)
p = InStr(Tmp, ".")
If p > 0 Then Tmp = Mid(Tmp, 1, p - 1)
If Len(Tmp) = 1 Then
If CLng(Tmp) = 0 Then Exit Do
End If
Loop
Dec2Bin = Bin
End Function
Public Function isEven(Dec As String) As Boolean
Dim OE As Long
Dim myDec As Variant
OE = CLng(Right$(CStr(Dec), 1))
isEven = (OE = 0 Or OE = 2 Or OE = 4 Or OE = 6 Or OE = 8)
End Function

The only convenient data type in VB6 that can accurately represent 10009335357561071 is the Variant's Decimal subtype. Both Double and Currency native types lack the precision required.
There is also the matter of handling signed values and for that matter how many bytes of precision are desired, whether leading zeros should be suppressed, and probably others.
It is very hard to conceive of a need for this in a real application.
Even if we presume you are doing something "especially special" or if some instructor has given you this problem as an aid to general understanding...
... there just isn't much you can do with this without a BigNum library of some sort, or possibly using Decimal with some care though it only gains you a few more digits of precision.

Here is a working sample (using Fix), that is not mine, credit to http://visualbasic.ittoolbox.com/groups/technical-functional/visualbasic-l/vb60-hex-function-overflow-error-2744358.
Private Function MyHex(ByVal TempDec As Double) As String
Dim TNo As Integer
MyHex = ""
Do
TNo = TempDec - (Fix(TempDec / 16) * 16)
If TNo > 9 Then
MyHex = Chr(55 + TNo) & MyHex
Else
MyHex = TNo & MyHex
End If
TempDec = Fix(TempDec / 16)
Loop Until (TempDec = 0)
End Function

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Function Dec2Hex(ByVal strDec As Variant) As String
Dim mybyte(0 To 19) As Byte
Dim lp As Long
CopyMemory mybyte(0), ByVal VarPtr(CDec(strDec)), 16
' Quick reorganise so we can then just step through the entire thing in one loop
For lp = 7 To 4 Step -1
mybyte(12 + lp) = mybyte(lp)
Next
' Build the hex string
For lp = 19 To 8 Step -1
If (Not Len(Dec2Hex) And mybyte(lp) <> 0) Or Len(Dec2Hex) Then
'Dec2Hex = Dec2Hex & Format(hex(mybyte(lp)), IIf(Len(Dec2Hex), "00", "0"))
Dec2Hex = Dec2Hex & IIf(Len(Dec2Hex), Right$("0" & hex(mybyte(lp)), 2), hex(mybyte(lp)))
End If
Next
End Function

Related

vb6 random number no duplicates & no zeros

I am using vb6 and trying to generate a random number or String with this format
S1 = "378125649"
I have three requirements NO Duplicates Values & No Zeros & 9 charcters in length
I have approached This two very different ways the random number generator method is failing the FindAndReplace works but is too much code
The questions are
How to fix the GetNumber method code to meet the three requirement?
OR
How to simplify the FindAndReplace code to reflect a completely new sequence of numbers each time?
GetNumber code Below
Private Sub GetNumber()
Randomize
Dim MyRandomNumber As Long 'The chosen number
Dim RandomMax As Long 'top end of range to pick from
Dim RandomMin As Long 'low end of range to pick from
'Dim Kount As Long 'loop to pick ten random numbers
RandomMin = 1
RandomMax = 999999999
MyRandomNumber = Int(Rnd(1) * RandomMax) + RandomMin
lbOne.AddItem CStr(MyRandomNumber) & vbNewLine
End Sub
The FindAndReplace Code Below
Private Sub FindAndReplace()
Dim S4 As String
S4 = "183657429"
Dim T1 As String
Dim T2 As String
Dim J As Integer
Dim H As Integer
J = InStr(1, S4, 2)
H = InStr(1, S4, 8)
T1 = Replace(S4, CStr(J), "X")
T1 = Replace(T1, CStr(H), "F")
If Mid(T1, 8, 1) = "F" And Mid(T1, 2, 1) = "X" Then
T2 = Replace(T1, "F", "8")
T2 = Replace(T2, "X", "2")
End If
tbOne.Text = CStr(J) & " " & CStr(H)
lbOne.AddItem "Original Value " & S4 & vbNewLine
lbOne.AddItem "New Value " & T2 & vbNewLine
End Sub
Here's a way of generating 9-digit random numbers with no zeroes. The basic idea is to build a 9-character string position by position where each position is a random number between 1 and 9. Then each string is added to a collection to remove any duplicates. This code will generate 100,000 unique numbers:
Option Explicit
Private Sub Command1_Click()
Dim c As Collection
Set c = GetNumbers()
MsgBox c.Count
End Sub
Private Function GetNumbers() As Collection
On Error Resume Next
Dim i As Integer
Dim n As String
Randomize
Set GetNumbers = New Collection
Do While GetNumbers.Count < 100000
n = ""
For i = 1 To 9
n = n & Int((9 * Rnd) + 1)
Next
GetNumbers.Add n, n
Loop
End Function
In my testing, this code only generated 2 duplicates for the 100,000 unique numbers returned.
I don't have a VB6 compiler, so I winged it:
Function GetNumber(lowerLimit as Integer, upperLimit As Integer) As Integer
Dim randomNumber As String
Dim numbers As New Collection
Randomize
For i As Integer = lowerLimit To upperLimit
Call numbers.Add(i)
Next
For j As Integer = upperLimit To lowerLimit Step -1
Dim position As Short = Int(((j - lowerLimit)* Rnd) + 1)
randomNumber = randomNumber & numbers(position)
Call numbers.Remove(position)
Next
Return(CInt(randomNumber))
End Function
Use that function by calling for example:
GetNumber(1, 9)
I don't have VB6 on my machines anymore, so here's a solution written in Excel that shuffles the digits in 123456789 using an array.
You should be able to use it with little conversion:
Private Function RndNumber() As String
Dim i, j As Integer
Dim tmp As Variant
Dim digits As Variant
digits = Array("1", "2", "3", "4", "5", "6", "7", "8", "9")
For i = 0 To UBound(digits)
j = Int(9 * Rnd)
tmp = digits(i)
digits(i) = digits(j)
digits(j) = tmp
Next
RndNumber = Join(digits, "")
End Function
Here's a variation to play with that will shuffle an array you pass in and join them together with the specified separator. Note that the arrays being passed in are of variant type so anything can be shuffled. The first array has numbers while the second array has strings:
Private Sub Foo()
Dim digits As Variant
digits = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
Dim rndNnumber As String
RndNumber = ShuffleArrayAndJoin(digits, "")
Debug.Print RndNumber
Dim pets As Variant
pets = Array("cat", "dog", "fish", "hamster")
Dim rndPets As String
rndPets = ShuffleArrayAndJoin(pets, ", ")
Debug.Print (rndPets)
End Sub
Private Function ShuffleArrayAndJoin(ByVal sourceArray As Variant, ByVal separator As String) As String
Dim i, j As Integer
Dim tmp As Variant
For i = 0 To UBound(sourceArray)
j = Int(UBound(sourceArray) * Rnd)
tmp = sourceArray(i)
sourceArray(i) = sourceArray(j)
sourceArray(j) = tmp
Next
ShuffleArrayAndJoin = Join(sourceArray, separator)
End Function
Function GetNumber() As String
Dim mNum As String
Randomize Timer
Do While Len(mNum) <> 9
mNum = Replace(Str(Round(Rnd(Timer), 6)) + Str(Round(Rnd(Timer), 3)), " .", "")
Loop
GetNumber = mNum
End Function
Been clicking a button to load a text box for a couple of minutes, but so far no dupes, and I'd bet money there never will be any..
Well, it solves just 1 problem: it will never ever repeat number
but it has to be 15+ numbers long...
Function genRndNr(nrPlaces) 'must be more then 10
Dim prefix As String
Dim suffix As String
Dim pon As Integer
prefix = Right("0000000000" + CStr(DateDiff("s", "2020-01-01", Now)), 10)
suffix = Space(nrPlaces - 10)
For pon = 1 To Len(suffix)
Randomize
Randomize Rnd * 1000000
Mid(suffix, pon, 1) = CStr(Int(Rnd * 10))
Next
genRndNr = prefix + suffix
End Function

Can anyone improve on the below Fuzzyfind function for VBA?

This function lets you find similar strings from a range without having to do an exact search.
The formula looks like this: =FuzzyFind(A1,B$1:B$20)
assuming the string you are performing a search for is in A1
and your reference or options table is B1:B20
The code is here:
Function FuzzyFind(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
For Each cell In tbl_array
str = cell
For i = 1 To Len(lookup_value)
If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
a = a + 1
cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
End If
Next i
a = a - Len(cell)
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
FuzzyFind = Value
End Function
The results from this function are hit and miss. Can anyone improve the intelligence of this algorithm?
Thank you :)
I'm not sure exactly what "FuzzyFind" entails, but this is a VLOOKUP that uses the Levenshtein distance to find similar data.
The Levenshtein distance lets you select a "percentage match" that you can specify instead of the typical TRUE or FALSE from a normal VLOOKUP:
Usage is: DTVLookup(A1,$C$1:$C$100,1,90) where 90 is the Levenshtein Distance.
DTVLookup(Value To Find, Range to Search, Column to Return, [Percentage Match])
I typically use this when comparing names that come from different databases like:
Correct Name Example Lookup Percentage Match Other Report
John S Smith John Smith 83 John Smith
Barb Jones Barbara Jones 77 Barbara Jones
Jeffrey Bridge Jeff Bridge 79 Jeff Bridge
Joseph Park Joseph P. Park 79 Joseph P. Park
Jefrey Jones jefre jon 75 jefre jon
Peter Bridge peter f. bridge 80 peter f. bridge
Here's the code:
Function DTVLookup(TheValue As Variant, TheRange As Range, TheColumn As Long, Optional PercentageMatch As Double = 100) As Variant
If TheColumn < 1 Then
DTVLookup = CVErr(xlErrValue)
Exit Function
End If
If TheColumn > TheRange.Columns.Count Then
DTVLookup = CVErr(xlErrRef)
Exit Function
End If
Dim c As Range
For Each c In TheRange.Columns(1).Cells
If UCase(TheValue) = UCase(c) Then
DTVLookup = c.Offset(0, TheColumn - 1)
Exit Function
ElseIf PercentageMatch <> 100 Then
If Levenshtein3(UCase(TheValue), UCase(c)) >= PercentageMatch Then
DTVLookup = c.Offset(0, TheColumn - 1)
Exit Function
End If
End If
Next c
DTVLookup = CVErr(xlErrNA)
End Function
Function Levenshtein3(ByVal string1 As String, ByVal string2 As String) As Long
Dim i As Long, j As Long, string1_length As Long, string2_length As Long
Dim distance(0 To 60, 0 To 50) As Long, smStr1(1 To 60) As Long, smStr2(1 To 50) As Long
Dim min1 As Long, min2 As Long, min3 As Long, minmin As Long, MaxL As Long
string1_length = Len(string1): string2_length = Len(string2)
distance(0, 0) = 0
For i = 1 To string1_length: distance(i, 0) = i: smStr1(i) = Asc(LCase(Mid$(string1, i, 1))): Next
For j = 1 To string2_length: distance(0, j) = j: smStr2(j) = Asc(LCase(Mid$(string2, j, 1))): Next
For i = 1 To string1_length
For j = 1 To string2_length
If smStr1(i) = smStr2(j) Then
distance(i, j) = distance(i - 1, j - 1)
Else
min1 = distance(i - 1, j) + 1
min2 = distance(i, j - 1) + 1
min3 = distance(i - 1, j - 1) + 1
If min2 < min1 Then
If min2 < min3 Then minmin = min2 Else minmin = min3
Else
If min1 < min3 Then minmin = min1 Else minmin = min3
End If
distance(i, j) = minmin
End If
Next
Next
' Levenshtein3 will properly return a percent match (100%=exact) based on similarities and Lengths etc...
MaxL = string1_length: If string2_length > MaxL Then MaxL = string2_length
Levenshtein3 = 100 - CLng((distance(string1_length, string2_length) * 100) / MaxL)
End Function
Try this out, I think it will find the best match
Function FuzzyFind2(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
Dim Found As Boolean
b = 0
For Each cell In tbl_array
str = cell
i = 1
Found = True
Do While Found = True
Found = False
If InStr(i, str, lookup_value) > 0 Then
a = a + 1
Found = True
i = InStr(i, str, lookup_value) + 1
End If
Loop
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
FuzzyFind2 = Value
End Function
I've been looking for this theme a lot and definitely Holmes IV answer is the best. I would just add a small update to compare always in uppercase. For my problems it recommended me more accurate options.
Function FuzzyFind3(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
Dim Found As Boolean
b = 0
For Each cell In tbl_array
str = UCase(cell)
i = 1
Found = True
Do While Found = True
Found = False
If InStr(i, str, UCase(lookup_value)) > 0 Then
a = a + 1
Found = True
i = InStr(i, str, UCase(lookup_value)) + 1
End If
Loop
If a > b Then
b = a
Value = str
End If
a = 0
Next cell
FuzzyFind3 = Value

Convert hex string (image) to base64 (for browser rendering) in VBScript

I have a script that outputs a .bmp captcha image.
The image is built in hexadecimal, and converted to binary and sent to the browser via response.binaryWrite chrB(CByte(myHexImage)) (as an image mime type = bmp)
I want the option to move away from that (changing mime type, etc) and toward just sending something to the output like this:
data:image/jpeg;base64,/9j/4AAQSkZJRgABAQAAAQABAAD/2 ...
(except that my images are BMP)
Is there a quick and easy way to convert that hex or binary to base64 in vbscript? Here is a snippet of what I have implmented now as described above.
how can I change this so I output, to the screen, valid hex format (which i can then easily convert to base64) or base64 directly?
Dim sBmpEndLine, sBmpInfoHeader, sBmpHeader, sTmpHex
If (m_iBmpWidth Mod 4) <> 0 Then
sBmpEndLine = string((4 - (m_iBmpWidth Mod 4)) * 2, "0")
Else
sBmpEndLine = vbNullString
End If
sBmpInfoHeader = array("28000000", "00000000", "00000000", "0100", "0800", "00000000", "00000000", "120B0000", "120B0000", "00000000", "00000000")
sBmpInfoHeader(1) = formatHex(hex(m_iBmpWidth), 4, 0, True)
sBmpInfoHeader(2) = formatHex(hex(m_iBmpHeight), 4, 0, True)
sBmpInfoHeader(6) = formatHex(hex((m_iBmpHeight * m_iBmpWidth) + (m_iBmpHeight * (len(sBmpEndLine) / 2))), 4, 0, True)
sBmpInfoHeader(9) = formatHex(hex(len(m_sBmpColorMap) / 8), 4, 0, True)
sBmpInfoHeader(10) = sBmpInfoHeader(9)
sBmpHeader = array("424D", "00000000", "0000", "0000", "00000000")
sBmpHeader(1) = formatHex(hex((len(join(sBmpHeader, "")) / 2) + (len(join(sBmpInfoHeader, "")) / 2) + (len(m_sBmpColorMap) / 2) + (m_iBmpHeight * m_iBmpWidth) + (m_iBmpHeight * (len(sBmpEndLine) / 2))), 4, 0, True)
sBmpHeader(4) = formatHex(hex((len(join(sBmpHeader, "")) / 2) + (len(join(sBmpInfoHeader, "")) / 2) + (len(m_sBmpColorMap) / 2)), 4, 0, True)
sendHex(join(sBmpHeader, ""))
sendHex(join(sBmpInfoHeader, ""))
sendHex(m_sBmpColorMap)
For y = m_iBmpHeight To 1 Step -1
For x = 1 To m_iBmpWidth
sTmpHex = m_aBitmap(y, x)
If sTmpHex = vbNullString Then
sendHex(m_sBgColor)
Else
sendHex(sTmpHex)
End If
Next
sendHex(sBmpEndLine)
Next
Response.Flush
And here is the sendHex() function:
Private Sub sendHex(valHex)
Dim iCntHex
For iCntHex = 1 To len(valHex) Step 2
'Response.BinaryWrite chrB(CByte("&H" & mid(valHex, iCntHex, 2)))
response.Write "&H" & mid(valHex, iCntHex, 2)
Next
End Sub
The Microsoft.XMLDOM has built in converters for bin.base64 and bin.hex. I wrote functions that demonstrate how to use this:
Function TextToBinary(text, dataType)
Dim dom
Set dom = CreateObject("Microsoft.XMLDOM")
dom.loadXML("<HELLO/>")
dom.documentElement.nodeTypedValue = text
dom.documentElement.dataType = dataType
TextToBinary = dom.documentElement.nodeTypedValue
End Function
Function BinaryToText(binary, dataType)
Dim dom
Set dom = CreateObject("Microsoft.XMLDOM")
dom.loadXML("<HELLO/>")
dom.documentElement.dataType = dataType
dom.documentElement.nodeTypedValue = binary
dom.documentElement.removeAttribute("dt:dt")
BinaryToText = dom.documentElement.nodeTypedValue
End Function
Function HexToBase64(strHex)
HexToBase64 = BinaryToText(TextToBinary(strHex, "bin.hex"), "bin.base64")
End Function
Function Base64ToHex(strBase64)
Base64ToHex = BinaryToText(TextToBinary(strBase64, "bin.base64"), "bin.hex")
End Function
Here's an example of their usage:
MsgBox HexToBase64("41")
MsgBox Base64ToHex("QQ==")
Also look at the ADODB.Stream as a means of working with binary files. It'll work with these routines.
I was able to get this working. Here is how.
In sendHex, I removed the &H portion, and wrapped my string in hex():
Private Sub sendHex(valHex)
Dim iCntHex
For iCntHex = 1 To len(valHex) Step 2
If len( mid(valHex, iCntHex, 2)) = 1 Then
response.write "0"
end if
response.write mid(valHex, iCntHex, 2)
Next
End Sub
This results in a string output like this (in byte strings of 2 hexidecimal chars):
424d1e050000000000003e00000028000000340000001800000001000
I can then dump that proper hex string into a HEX to base64 function as follows (not written by me, but rather, by Richard Mueller - http://www.rlmueller.net/Base64.htm)
Function HexToBase64(strHex)
' Function to convert a hex string into a base64 encoded string.
' Constant B64 has global scope.
Dim lngValue, lngTemp, lngChar, intLen, k, j, strWord, str64, intTerm
intLen = Len(strHex)
' Pad with zeros to multiple of 3 bytes.
intTerm = intLen Mod 6
If (intTerm = 4) Then
strHex = strHex & "00"
intLen = intLen + 2
End If
If (intTerm = 2) Then
strHex = strHex & "0000"
intLen = intLen + 4
End If
' Parse into groups of 3 hex bytes.
j = 0
strWord = ""
HexToBase64 = ""
For k = 1 To intLen Step 2
j = j + 1
strWord = strWord & Mid(strHex, k, 2)
If (j = 3) Then
' Convert 3 8-bit bytes into 4 6-bit characters.
lngValue = CCur("&H" & strWord)
lngTemp = Fix(lngValue / 64)
lngChar = lngValue - (64 * lngTemp)
str64 = Mid(B64, lngChar + 1, 1)
lngValue = lngTemp
lngTemp = Fix(lngValue / 64)
lngChar = lngValue - (64 * lngTemp)
str64 = Mid(B64, lngChar + 1, 1) & str64
lngValue = lngTemp
lngTemp = Fix(lngValue / 64)
lngChar = lngValue - (64 * lngTemp)
str64 = Mid(B64, lngChar + 1, 1) & str64
str64 = Mid(B64, lngTemp + 1, 1) & str64
HexToBase64 = HexToBase64 & str64
j = 0
strWord = ""
End If
Next
' Account for padding.
If (intTerm = 4) Then
HexToBase64 = Left(HexToBase64, Len(HexToBase64) - 1) & "="
End If
If (intTerm = 2) Then
HexToBase64 = Left(HexToBase64, Len(HexToBase64) - 2) & "=="
End If
End Function
This converts the above to base64, and I can use the output like this (e.g. in a browser url bar) to view it as an image:
data:image/bmp;base64,Qk0eBQAAAAAAAD4AAAAo...

Memory and execution time reduction for algorithms

I have been asked to ask this question again and in a little different context. This is the previous post:
Filtering in VBA after finding combinations
I would like to make this code possible with 100 different variables without having excel run out of memory and reducing the execution time significantly.
The problem with the code below is that if I have 100 boxes, excel will run out of memory in the line "Result(0 To 2 ^ NumFields - 2)" ( The code works for < 10 boxes)
This is my input:
3 A B C D E ...
7.7 3 1 1 1 2 ...
5.5 2 1 2 3 3 ...
This is the code:
Function stackBox()
Dim ws As Worksheet
Dim width As Long
Dim height As Long
Dim numOfBox As Long
Dim optionsA() As Variant
Dim results() As Variant
Dim str As String
Dim outputArray As Variant
Dim i As Long, j As Long
Dim currentSymbol As String
'------------------------------------new part----------------------------------------------
Dim maxHeight As Double
Dim maxWeight As Double
Dim heightarray As Variant
Dim weightarray As Variant
Dim totalHeight As Double
Dim totalWeight As Double
'------------------------------------new part----------------------------------------------
Set ws = Worksheets("Sheet1")
With ws
'clear last time's output
height = .Cells(.Rows.Count, 1).End(xlUp).row
If height > 3 Then
.Range(.Cells(4, 1), .Cells(height, 1)).ClearContents
End If
numOfBox = .Cells(1, 1).Value
width = .Cells(1, .Columns.Count).End(xlToLeft).Column
If width < 2 Then
MsgBox "Error: There's no item, please fill your item in Cell B1,C1,..."
Exit Function
End If
'------------------------------------new part----------------------------------------------
maxHeight = .Cells(2, 1).Value
maxWeight = .Cells(3, 1).Value
ReDim heightarray(1 To 1, 1 To width - 1)
ReDim weightarray(1 To 1, 1 To width - 1)
heightarray = .Range(.Cells(2, 2), .Cells(2, width)).Value
weightarray = .Range(.Cells(3, 2), .Cells(3, width)).Value
'------------------------------------new part----------------------------------------------
ReDim optionsA(0 To width - 2)
For i = 0 To width - 2
optionsA(i) = .Cells(1, i + 2).Value
Next i
GenerateCombinations optionsA, results, numOfBox
' copy the result to sheet only once
ReDim outputArray(1 To UBound(results, 1) - LBound(results, 1) + 1, 1 To 1)
Count = 0
For i = LBound(results, 1) To UBound(results, 1)
If Not IsEmpty(results(i)) Then
'rowNum = rowNum + 1
str = ""
totalHeight = 0#
totalWeight = 0#
For j = LBound(results(i), 1) To UBound(results(i), 1)
currentSymbol = results(i)(j)
str = str & currentSymbol 'results(i)(j) is the SYMBOL e.g. A, B, C
'look up box's height and weight , increment the totalHeight/totalWeight
updateParam currentSymbol, optionsA, heightarray, weightarray, totalHeight, totalWeight
Next j
If totalHeight < maxHeight And totalWeight < maxWeight Then
Count = Count + 1
outputArray(Count, 1) = str
End If
'.Cells(rowNum, 1).Value = str
End If
Next i
.Range(.Cells(4, 1), .Cells(UBound(outputArray, 1) + 3, 1)).Value = outputArray
End With
End Function
Sub updateParam(ByRef targetSymbol As String, ByRef symbolArray As Variant, ByRef heightarray As Variant, ByRef weightarray As Variant, ByRef totalHeight As Double, ByRef totalWeight As Double)
Dim i As Long
Dim index As Long
index = -1
For i = LBound(symbolArray, 1) To UBound(symbolArray, 1)
If targetSymbol = symbolArray(i) Then
index = i
Exit For
End If
Next i
If index <> -1 Then
totalHeight = totalHeight + heightarray(1, index + 1)
totalWeight = totalWeight + weightarray(1, index + 1)
End If
End Sub
Sub GenerateCombinations(ByRef AllFields() As Variant, _
ByRef Result() As Variant, ByVal numOfBox As Long)
Dim InxResultCrnt As Integer
Dim InxField As Integer
Dim InxResult As Integer
Dim i As Integer
Dim NumFields As Integer
Dim Powers() As Integer
Dim ResultCrnt() As String
NumFields = UBound(AllFields) - LBound(AllFields) + 1
ReDim Result(0 To 2 ^ NumFields - 2) ' one entry per combination
ReDim Powers(0 To NumFields - 1) ' one entry per field name
' Generate powers used for extracting bits from InxResult
For InxField = 0 To NumFields - 1
Powers(InxField) = 2 ^ InxField
Next
For InxResult = 0 To 2 ^ NumFields - 2
' Size ResultCrnt to the max number of fields per combination
' Build this loop's combination in ResultCrnt
ReDim ResultCrnt(0 To NumFields - 1)
InxResultCrnt = -1
For InxField = 0 To NumFields - 1
If ((InxResult + 1) And Powers(InxField)) <> 0 Then
' This field required in this combination
InxResultCrnt = InxResultCrnt + 1
ResultCrnt(InxResultCrnt) = AllFields(InxField)
End If
Next
If InxResultCrnt = 0 Then
Debug.Print "testing"
End If
'additional logic here
If InxResultCrnt >= numOfBox Then
Result(InxResult) = Empty
Else
' Discard unused trailing entries
ReDim Preserve ResultCrnt(0 To InxResultCrnt)
' Store this loop's combination in return array
Result(InxResult) = ResultCrnt
End If
Next
End Sub
Here's a version that does all the heavy lifting in variant arrays
(Combinations logic based on this answer for This Answer by Joubarc)
This runs on a sample dataset of 100 boxes with > 40,000 returned, and in < 1 second
Notes:
Execution time rises quickly if the Max number of boxes increases (eg 4 from 100: approx 13s)
If the number of returned results exceeds 65535, the code to tranpose the array into the sheet fails (last line of the sub) If you need to handle this may results, you will need to change the way results are returned to the sheet
Sub Demo()
Dim rNames As Range
Dim rHeights As Range
Dim rWeights As Range
Dim aNames As Variant
Dim aHeights As Variant
Dim aWeights As Variant
Dim MaxNum As Long
Dim MaxHeight As Double
Dim MaxWeight As Double
' *** replace these six line with your data ranges
Set rNames = Range([F5], [F5].End(xlToRight))
Set rHeights = rNames.Offset(1, 0)
Set rWeights = rNames.Offset(2, 0)
MaxNum = [C5]
MaxHeight = [C6]
MaxWeight = [C7]
aNames = rNames
aHeights = rHeights
aWeights = rWeights
Dim Result() As Variant
Dim n As Long, m As Long
Dim i As Long, j As Long
Dim iRes As Long
Dim res As String
Dim TestCombin() As Long
Dim TestWeight As Double
Dim TestHeight As Double
Dim idx() As Long
' Number of boxes
ReDim TestCombin(0 To MaxNum - 1)
n = UBound(aNames, 2) - LBound(aNames, 2) + 1
' estimate size of result array = number of possible combinations
For m = 1 To MaxNum
i = i + Application.WorksheetFunction.Combin(n, m)
Next
ReDim Result(1 To 3, 1 To i)
' allow for from 1 to MaxNum of boxes
iRes = 1
For m = 1 To MaxNum
ReDim idx(0 To m - 1)
For i = 0 To m - 1
idx(i) = i
Next i
Do
'Test current combination
res = ""
TestWeight = 0#
TestHeight = 0#
For j = 0 To m - 1
'Debug.Print aNames(1, idx(j) + 1);
res = res & aNames(1, idx(j) + 1)
TestWeight = TestWeight + aWeights(1, idx(j) + 1)
TestHeight = TestHeight + aHeights(1, idx(j) + 1)
Next j
'Debug.Print
If TestWeight <= MaxWeight And TestHeight <= MaxHeight Then
Result(1, iRes) = res
' optional, include actual Height and Weight in result
Result(2, iRes) = TestHeight
Result(3, iRes) = TestWeight
iRes = iRes + 1
End If
' Locate last non-max index
i = m - 1
While (idx(i) = n - m + i)
i = i - 1
If i < 0 Then
'All indexes have reached their max, so we're done
Exit Do
End If
Wend
'Increase it and populate the following indexes accordingly
idx(i) = idx(i) + 1
For j = i To m - 1
idx(j) = idx(i) + j - i
Next j
Loop
Next
' Return Result to sheet
Dim rng As Range
ReDim Preserve Result(1 To 3, 1 To iRes)
' *** Adjust returnm range to suit
Set rng = [E10].Resize(UBound(Result, 2), UBound(Result, 1))
rng = Application.Transpose(Result)
End Sub

VBA - Remove both items from array when not unique

Quick question that I've been struggling with. I have 2 arrays of different lengths that contain strings.
I want to output a new array which removes BOTH the elements if a duplicate is detected. At the moment it only removes duplicates but leaves the original which is incorrect for what I am trying to accomplish.
E.g.
input = array ("cat","dog","mouse","cat")
expected output = array ("dog","mouse")
actual output = array ("cat","dog","mouse")
Code is below:
Sub removeDuplicates(CombinedArray)
Dim myCol As Collection
Dim idx As Long
Set myCol = New Collection
On Error Resume Next
For idx = LBound(CombinedArray) To UBound(CombinedArray)
myCol.Add 0, CStr(CombinedArray(idx))
If Err Then
CombinedArray(idx) = Empty
dups = dups + 1
Err.Clear
ElseIf dups Then
CombinedArray(idx - dups) = CombinedArray(idx)
CombinedArray(idx) = Empty
End If
Next
For idx = LBound(CombinedArray) To UBound(CombinedArray)
Debug.Print CombinedArray(idx)
Next
removeBlanks (CombinedArray)
End Sub
Thanks for all help and support in advance.
What about using Scripting.Dictionary? Like this:
Function RemoveDuplicates(ia() As Variant)
Dim c As Object
Set c = CreateObject("Scripting.Dictionary")
Dim v As Variant
For Each v In ia
If c.Exists(v) Then
c(v) = c(v) + 1
Else
c.Add v, 1
End If
Next
Dim out() As Variant
Dim nOut As Integer
nOut = 0
For Each v In ia
If c(v) = 1 Then
ReDim Preserve out(nOut) 'you will have to increment nOut first, if you have 1-based arrays
out(nOut) = v
nOut = nOut + 1
End If
Next
RemoveDuplicates = out
End Function
Here is a quick example. Let me know if you get any errors.
Sub Sample()
Dim inputAr(5) As String, outputAr() As String, temp As String
Dim n As Long, i As Long
inputAr(0) = "cat": inputAr(1) = "Hen": inputAr(2) = "mouse"
inputAr(3) = "cat": inputAr(4) = "dog": inputAr(5) = "Hen"
BubbleSort inputAr
For i = 1 To UBound(inputAr)
If inputAr(i) = inputAr(i - 1) Or inputAr(i) = temp Then
inputAr(i - 1) = "": temp = inputAr(i): inputAr(i) = ""
End If
Next i
n = 0
For i = 1 To UBound(inputAr)
If inputAr(i) <> "" Then
n = n + 1
ReDim Preserve outputAr(n)
outputAr(n) = inputAr(i)
End If
Next i
For i = 1 To UBound(outputAr)
Debug.Print outputAr(i)
Next i
End Sub
Sub BubbleSort(arr)
Dim value As Variant
Dim i As Long, a As Long, b As Long, c As Long
a = LBound(arr): b = UBound(arr)
Do
c = b - 1
b = 0
For i = a To c
value = arr(i)
If (value > arr(i + 1)) Xor False Then
arr(i) = arr(i + 1)
arr(i + 1) = value
b = i
End If
Next
Loop While b
End Sub
EDIT
Another way without sorting
Sub Sample()
Dim inputAr(5) As String, outputAr() As String
Dim n As Long, i As Long, j As Long
Dim RemOrg As Boolean
inputAr(0) = "cat": inputAr(1) = "Hen": inputAr(2) = "mouse"
inputAr(3) = "cat": inputAr(4) = "dog": inputAr(5) = "Hen"
For i = 0 To UBound(inputAr)
For j = 1 To UBound(inputAr)
If inputAr(i) = inputAr(j) Then
If i <> j Then
inputAr(j) = "": RemOrg = True
End If
End If
Next
If RemOrg = True Then
inputAr(i) = ""
RemOrg = False
End If
Next i
n = 0
For i = 0 To UBound(inputAr)
If inputAr(i) <> "" Then
n = n + 1
ReDim Preserve outputAr(n)
outputAr(n) = inputAr(i)
End If
Next i
For i = 1 To UBound(outputAr)
Debug.Print outputAr(i)
Next i
End Sub

Resources