VBA - Remove both items from array when not unique - windows

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

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

How to sort an array ("10a", "23a", "1a", "2a") using VBScript

How to sort below array
Dim testarray = new Array("10a", "23a", "2c", "2a")
using VBScript to give output like "2a", "2c","10a", "23a".
You can use an ArrayList instead of an array:
testarrray = Array("10a", "23a", "2c", "2a")
Set testlist = CreateObject("System.Collections.ArrayList")
For i=0 To UBound(testarray)
testlist.Add testarray(i)
Next
For Each e In testlist
WScript.Echo e
Next
testarray.Sort
For Each e In testlist
WScript.Echo e
Next
Otherwise you'll have to implement a sorting algorithm yourself. VBScript doesn't have that functionality built into it.
For simple cases like your example bubblesort is probably the easiest to implement:
Function Bubblesort(ByVal arr)
For i = 0 To UBound(arr)
For j = i + 1 to UBound(arr)
If arr(i) > arr(j) Then
tmp = arr(i)
arr(i) = arr(j)
arr(j) = tmp
End If
Next
Next
Bubblesort = arr
End Function
only solution i found is to split the numeric part and then compare the numeric part first and then the character part.
Function sort(iparrary)
For i = 0 to ubound(iparrary)
For j= i+1 to ubound(iparrary)
num1 = getnumber(iparrary(i))
num2 = getnumber(iparrary(j))
if (num1 <> "" and num2 <> "") then
if cint(num1) > cint(num2) then
temp = iparrary(i)
iparrary(i) = iparrary(j)
iparrary(j) = temp
End if
End if
if num1 = num2 or num1="" or num2 = "" then
if(iparrary(i) > iparrary(j)) then
temp = iparrary(i)
iparrary(i) = iparrary(j)
iparrary(j) = temp
End if
End if
Next
Next
End Function
Function getnumber(strnumber)
dim intnum
intnum = ""
For num = 1 to len(strnumber)
chardata = mid(strnumber,num,1)
if isnumeric(chardata) then
intnum= intnum & chardata
else
getnumber = intnum
Exit function
End if
Next
getnumber = intnum
End Function
works exactly how i wanted.

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

Count how many specific characters in string

I have a search box.
My admin user might search for "#MG #EB dorchester".
In ASP, I need to count how many times the symbol "#" appears in the string. How is the possible?
Try this:
len(yourString) - len(replace(yourString, "#", ""))
Response.write ubound(split(str,"#"))
is enough for counting the occurance of a specific character
For JW01
Dim pos : pos = 0
Dim count : count = -1
Do
count = count + 1
pos = InStr(pos + 1, str, "#")
Loop While (pos > 0)
Try a while loop:
Do While (str.indexOf("#") != -1)
count = count + 1
str = right(str, len(str) - str.indexOf("#"))
Loop
EDIT:
This for loop might make more sense:
dim strLen, curChar, count
count = 0
int strLen = len(str)
for i = 1 to strLen
curChar = mid(str, i, 1)
if curChar = "#"
count = count + 1
end if
next
Replace the search with blank and find the difference between and original and new string will the number of time a string is present
Dim a = "I # am # Thirs#ty"
Dim count
count = Len(a) - Len(Replace(a,"#",""))
Response.write count
Function FnMatchedStringCountFromText(strText,strStringToSearch)
strLength = Len(strText)
strNumber = 1
IntCount = 0
For i = 1 to strLength
If Instr(1,strText,strStringToSearch,0) > 0 Then
stMatch = Instr(1,strText,strStringToSearch,0)
strText = Mid(strText,stMatch+2,strLength)
IntCount = IntCount+1
Else
Exit For
End If
Next
FnMatchedStringCountFromText = IntCount
End Function

WORD VBA Sort Ascending and Sort Descending

Here is code I have that sorts the words inside an array into ascending order. I need help to change it in such a way that it will also sort the words in descending order, all in a single function. Please help. Thanks!
Function Sort_Asc(ByRef str() As String)
Dim iLower As Integer, iUpper As Integer, iCount As Integer, Temp As String
Dim str2 As String
iUpper = UBound(str)
iLower = 1
Dim bSorted As Boolean
bSorted = False
Do While Not bSorted
bSorted = True
For iCount = iLower To iUpper - 1
str2 = StrComp(str(iCount), str(iCount + 1), vbTextCompare)
If str2 = 1 Then
Temp = str(iCount + 1)
str(iCount + 1) = str(iCount)
str(iCount) = Temp
bSorted = False
End If
Next iCount
iUpper = iUpper - 1
Loop
End Function
How about
Function Sort(ByRef str() As String, ByVal booAsc As Boolean)
Dim iLower As Integer, iUpper As Integer, iCount As Integer, Temp As String
Dim str2 As String
iUpper = UBound(str)
iLower = 1
Dim bSorted As Boolean
bSorted = False
Do While Not bSorted
bSorted = True
For iCount = iLower To iUpper - 1
If booAsc Then
str2 = StrComp(str(iCount + 1), str(iCount), vbTextCompare)
Else
str2 = StrComp(str(iCount), str(iCount + 1), vbTextCompare)
End If
If str2 = 1 Then
Temp = str(iCount + 1)
str(iCount + 1) = str(iCount)
str(iCount) = Temp
bSorted = False
End If
Next iCount
iUpper = iUpper - 1
Loop
End Function
and call the function using Sort strArray, False '(False Ascending, True Descending)

Resources