I have a 182.123 size array and I want to sort them by an specific attribute of the class of the array. The class is called CFlujo and the property I want to sort them by is by a string called id_flujo. So far I'm doing a bubble sort like this but it just takes too long:
Sub sort_arreglo(arreglo As Variant)
For x = LBound(arreglo) To UBound(arreglo)
For y = x To UBound(arreglo)
Dim aux As CFlujo
aux = New CFlujo
If UCase(arreglo(y).id_flujo) < UCase(arreglo(x).id_flujo) Then
Set aux = arreglo(y)
Set arreglo(y) = arreglo(x)
Set arreglo(x) = aux
End If
Next y
Next x
End Sub
So far I've researched the Selection Sort but I know you can't delete items from an array so I can't make two lists to sort the values from one to the other. I could put my data in collection but I have had trouble regarding the quality of the data unless I alocate the memory beforehand (like in an array).
There's a couple of things you can do to improve the execution time:
Load all the properties in an array
Sort some pointers instead of the objects
Use a better algorithm like QucikSort
With you example:
Sub Sort(arreglo As Variant)
Dim cache, vals(), ptrs() As Long, i As Long
ReDim vals(LBound(arreglo) To UBound(arreglo))
ReDim ptrs(LBound(arreglo) To UBound(arreglo))
' load the properties and fill the pointers
For i = LBound(arreglo) To UBound(arreglo)
vals(i) = UCase(arreglo(i).id_flujo)
ptrs(i) = i
Next
' sort the pointers
QuickSort vals, ptrs, 0, UBound(vals)
' make a copy
cache = arreglo
' set the value for each pointer
For i = LBound(arreglo) To UBound(arreglo)
Set arreglo(i) = cache(ptrs(i))
Next
End Sub
Private Sub QuickSort(vals(), ptrs() As Long, ByVal i1 As Long, ByVal i2 As Long)
Dim lo As Long, hi As Long, p As Long, tmp As Long
lo = i1
hi = i2
p = ptrs((i1 + i2) \ 2)
Do
While vals(ptrs(lo)) < vals(p): lo = lo + 1: Wend
While vals(ptrs(hi)) > vals(p): hi = hi - 1: Wend
If lo <= hi Then
tmp = ptrs(hi)
ptrs(hi) = ptrs(lo)
ptrs(lo) = tmp
lo = lo + 1
hi = hi - 1
End If
Loop While lo <= hi
If i1 < hi Then QuickSort vals, ptrs, i1, hi
If lo < i2 Then QuickSort vals, ptrs, lo, i2
End Sub
Related
I need to do the ‘vlookup’ function using the VBA. I need to lookup data from a access database containg 4.6 million records.
Private Sub connectDB()
Dim sqlstr As String
Dim mydata As String
Dim t, d, conn, rst, mydata
Dim arr, arr1
t = Timer
Set d = CreateObject("scripting.dictionary")
Set conn = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.Recordset")
mydata = "mydatabase"
strconn = "Provider = Microsoft.ACE.OLEDB.16.0; Data Source = " & mydata
sqlstr = "select Tracking, MAWB from total"
rst.Open sqlstr, strconn, 3, 2
arr1 = Array("Tracking", "MAWB")
arr = rst.GetRows(-1, 1, arr1)
STOP
#Above cost 1mins
For i = 0 To UBound(arr, 2)
d(arr(0, i)) = arr(1, i)
Next
STOP
#Put data into dictionary always costs me 20 mins
The procedure above always cost me around 20 mins. And the majority of them are spent on the putting data into dictionary
Anyway to reduce the time cost?
You could reduce significantly the lookup time by implementing your own hashtable/dictionary.
Here's an example indexing a 4 millions array under 5 seconds:
Private Declare PtrSafe Function RtlComputeCrc32 Lib "ntdll.dll" ( _
ByVal start As Long, ByVal data As LongPtr, ByVal size As Long) As Long
Sub Example()
Dim data(), slots() As Long, i As Long
' generate some records '
ReDim data(0 To 1, 0 To 4000000)
For i = 0 To UBound(data, 2)
data(0, i) = CStr(i)
Next
' index all the keys from column 1 '
MapKeys slots, data, column:=0
' lookup a key in column 1 '
i = IndexOfKey(slots, data, column:=0, key:="4876")
If i >= 0 Then
Debug.Print "Found at index " & i
Else
Debug.Print "Missing"
End If
End Sub
Public Sub MapKeys(slots() As Long, data(), column As Long)
Dim bucketsCount&, key$, r&, i&, s&, h&
bucketsCount = UBound(data, 2) * 0.9 ' n * load factor '
ReDim slots(0 To UBound(data, 2) + bucketsCount)
For r = 0 To UBound(data, 2) ' each record '
key = data(column, r)
h = RtlComputeCrc32(0, StrPtr(key), LenB(key)) And &H7FFFFFF ' get hash '
s = UBound(slots) - (h Mod bucketsCount) ' get slot '
Do
i = slots(s) - 1& ' get index (base 0) '
If i >= 0& Then ' if index for hash '
If data(column, i) = data(column, r) Then Exit Do ' if key present, handle next record '
Else
slots(s) = r + 1& ' add index (base 1) '
Exit Do
End If
s = i ' collision, index points to the next slot '
Loop
Next
End Sub
Public Function IndexOfKey(slots() As Long, data(), column As Long, key As String) As Long
Dim h&, s&, i&
h = RtlComputeCrc32(0, StrPtr(key), LenB(key)) And &H7FFFFFF ' get hash '
s = UBound(slots) - (h Mod (UBound(slots) - UBound(data, 2))) ' get slot '
i = slots(s) - 1& ' get index (base 0) '
Do While i >= 0&
If data(column, i) = key Then Exit Do ' break if same key '
i = slots(i) - 1& ' collision, index points to the next slot '
Loop
IndexOfKey = i
End Function
Although scripting dictionary is pretty fast at performing lookups, loading one up gets progressively slower the more you put into it: when you're in the millions of items then it gets really slow to load.
So, you could maybe consider something like splitting your values across an array of dictionary objects. All other excellent suggestions aside, this would at least reduce your runtime with your current setup. The only caveat is the "keys" queried from your database would need to be unique.
Sub LookupTester()
Const NUM_VALUES As Long = 4000000# '<< size of total dataset
Const MAX_PER_DICT As Long = 400000 '<< max # of entries per dictionary
Dim numDicts As Long, i As Long, n, t, d, v, r, c As Long
Dim arrD() As Scripting.Dictionary
numDicts = Application.Ceiling(NUM_VALUES / MAX_PER_DICT, 1)
ReDim arrD(1 To numDicts)
'initialize the array of dictionaries
For n = 1 To numDicts
Set arrD(n) = New Scripting.Dictionary
Next n
t = Timer
n = 1
c = 0
Set d = arrD(n)
'Load up some dummy data...
For i = 1 To NUM_VALUES
d("Value_" & i) = i
c = c + 1
If i Mod 400000 = 0 Then Debug.Print "Store", i, Timer - t 'check progresss
If c = MAX_PER_DICT Then
n = n + 1
If i <> NUM_VALUES Then Set d = arrD(n)'<< next dict
c = 0
End If
Next i
'Done storing: 87 sec in my test
t = Timer
Randomize
'perform a million lookups
For i = 1 To 1000000#
v = "Value_" & CLng(Rnd() * NUM_VALUES)
For n = 1 To numDicts
If arrD(n).Exists(v) Then
r = arrD(n)(v) '<< lookup result
Exit For
End If
Next n
If i Mod 100000 = 0 Then Debug.Print "Query", i, Timer - t
Next i
'Done querying: ~320 sec to run the queries
End Sub
You could wrap up this type of thing into a nice class...
my project is to predict non-ideal gas movement, so i wrote this code to give every molecule a specific number, but it keeps repeating numbers (i used randbetween)
how do i chnge it so it wont repeat the same number?
Sub Rand_Number()
'áåçø 20 àçåæ ùì îñôøé äîåì÷åìåú
Dim RandNum As Long
Dim k As Long
Dim Mone As Integer
Mone = 0
Num_molecules = Sheets("Data").Range("A14").Value
RandNum = WorksheetFunction.RandBetween(1, Num_molecules)
For j = 1 To Num_molecules * 0.2
If IsEmpty(Sheets("rand").Cells(1, 1)) = True Then
Sheets("rand").Cells(1, 1) = RandNum
Else
i = 1
'RandNum = WorksheetFunction.RandBetween(1, Num_molecules)
Do 'Until IsEmpty(Sheets("rand").Cells(i, 1)) = True
If Sheets("rand").Cells(i, 1) = RandNum Then
RandNum = WorksheetFunction.RandBetween(1, Num_molecules)
Do Until RandNum = Cells(i, 1) Or IsEmpty(Cells(i, 1)) = True
If RandNum = Sheets("rand").Cells(i, 1) Then
RandNum = WorksheetFunction.RandBetween(1, Num_molecules)
Else
i = i + 1
End If
Loop
ElseIf IsEmpty(Sheets("rand").Cells(i, 1)) = False Then
i = i + 1
Else
Sheets("rand").Cells(i, 1) = RandNum
Exit Do
End If
Loop
End If
Next j
End Sub
Generation of numbers until all numbers from the range are generated. It is inefficient as towards the end of the algorithm most random numbers become a "miss", but it is still more efficient than collection's remove method below.
Sub uniqRndMissedHits()
Dim lb As Long: lb = 1 ' lower bound
Dim ub As Long: ub = 1000 ' upper bound
' populate collection with numbers starting from lb to ub
Dim i As Long
Dim c As New Collection
' iterate while we haven't generated all the random numbers
' in the specified range
While c.Count < ub - lb + 1
i = Int((ub - lb + 1) * Rnd + lb)
If Not contains(c, CStr(i)) Then
c.Add i, CStr(i)
Debug.Print i ' this is your unique random number from the
' remaining in the collection
End If
Wend
End Sub
Function contains(col As Collection, key As String) As Boolean
On Error Resume Next
col.Item key
contains = (Err.Number = 0)
On Error GoTo 0
End Function
This example generates a guaranteed unique (i.e. previously not generated) values, but Remove method of the Collection makes it inefficient for large number of simulations.
Sub uniqRnd()
Dim lb As Long: lb = 1 ' lower bound
Dim ub As Long: ub = 1000 ' upper bound
' populate collection with numbers starting from lb to ub
Dim i As Long
Dim c As New Collection
For i = lb To ub: c.Add i: Next
' randomly pick the number and (!) remove it from the
' collection at the same time so it won't be repeated
While c.Count > 0
lb = 1
ub = c.Count
i = Int((ub - lb + 1) * Rnd + lb)
Debug.Print c(i) ' this is your unique random number from the
' remaining in the collection
c.Remove i
Wend
End Sub
Comparison of performance of all the methods in this answer can be found in this GitHub Gist Excel VBA: Generate complete set of unique random numbers
I'd recommend using a dictionary to keep track of the random numbers that have been generated so far. If the number doesn't exist in the dictionary you can proceed with the simulation, otherwise you could generate a new random number (this would be the Else condition)
Using a dictionary is very fast for doing the lookup.
Here's a code sample of how to work with a dictionary.
Public Sub DictionaryExample()
Dim myDict As Object: Set myDict = CreateObject("Scripting.Dictionary")
Dim myRand As Long
Dim i As Long
For i = 1 To 10000
myRand = WorksheetFunction.RandBetween(1, 10000)
If myDict.exists(myRand) = False Then ' The random number doesn't exist in the previous items added
'If it doesn't exist, add it to the dictionary
myDict.Add myRand, myRand 'First parameter is the key, or the unique value
'The second parameter is the value associated with the key, the lookup value
Else
'Do something here when it does exist
End If
Next i
End Sub
Right, so using Python I would create a multidimensional list and set the values on one line of code (as per the below).
aryTitle = [["Desciption", "Value"],["Description2", "Value2"]]
print(aryTitle[0,0] + aryTitle[0,1])
I like the way I can set the values on one line. In VBA I am doing this by:
Dim aryTitle(0 To 1, 0 To 1) As String
aryTitle(0, 0) = "Description"
aryTitle(0, 1) = "Value"
aryTitle(1, 0) = "Description2"
aryTitle(1, 1) = "Value2"
MsgBox (aryTitle(0, 0) & aryTitle(0, 1))
Is there a way to set the values in one line of code?
Not natively, no. But you can write a function for it. The only reason Python can do that is someone wrote a function to do it. The difference is that they had access to the source so they could make the syntax whatever they like. You'll be limited to VBA function syntax. Here's a function to create a 2-dim array. It's not technically 'one line of code', but throw it in your MUtilities module and forget about it and it will feel like one line of code.
Public Function FillTwoDim(ParamArray KeyValue() As Variant) As Variant
Dim aReturn() As Variant
Dim i As Long
Dim lCnt As Long
ReDim aReturn(0 To ((UBound(KeyValue) + 1) \ 2) - 1, 0 To 1)
For i = LBound(KeyValue) To UBound(KeyValue) Step 2
If i + 1 <= UBound(KeyValue) Then
aReturn(lCnt, 0) = KeyValue(i)
aReturn(lCnt, 1) = KeyValue(i + 1)
lCnt = lCnt + 1
End If
Next i
FillTwoDim = aReturn
End Function
Sub test()
Dim vaArr As Variant
Dim i As Long
Dim j As Long
vaArr = FillTwoDim("Description", "Value", "Description2", "Value2")
For i = LBound(vaArr, 1) To UBound(vaArr, 1)
For j = LBound(vaArr, 2) To UBound(vaArr, 2)
Debug.Print i, j, vaArr(i, j)
Next j
Next i
End Sub
If you supply an odd number of arguments, it ignores the last one. If you use 3-dim arrays, you could write a function for that. You could also write a fancy function that could handle any dims, but I'm not sure it's worth it. And if you're using more than 3-dim arrays, you probably don't need my help writing a function.
The output from the above
0 0 Description
0 1 Value
1 0 Description2
1 1 Value2
You can write a helper function:
Function MultiSplit(s As String, Optional delim1 As String = ",", Optional delim2 As String = ";") As Variant
Dim V As Variant, W As Variant, A As Variant
Dim i As Long, j As Long, m As Long, n As Long
V = Split(s, delim2)
m = UBound(V)
n = UBound(Split(V(0), delim1))
ReDim A(0 To m, 0 To n)
For i = 0 To m
For j = 0 To n
W = Split(V(i), delim1)
A(i, j) = Trim(W(j))
Next j
Next i
MultiSplit = A
End Function
Used like this:
Sub test()
Dim A As Variant
A = MultiSplit("Desciption, Value; Description2, Value2")
Range("A1:B2").Value = A
End Sub
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 created a trivia game using visual basic for applications (Excel) that chooses questions by going through a case statement where the cases are numbers. I have the program randomly select a number from 1 to the max amount of questions there are. Using this method, the game repeats questions.
Is there a way to make something that generates numbers randomly (different results every time) and doesn't repeat a number more than once? And after it's gone through all the numbers it needs to execute a certain code. (I'll put in code that ends the game and displays the number of questions they got right and got wrong)
I thought of a few different ways to do this, however I couldn't even begin to think of what the syntax might be.
Sounds like you need an Array Shuffler!
Check out the below link -
http://www.cpearson.com/excel/ShuffleArray.aspx
Function ShuffleArray(InArray() As Variant) As Variant()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShuffleArray
' This function returns the values of InArray in random order. The original
' InArray is not modified.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim N As Long
Dim Temp As Variant
Dim J As Long
Dim Arr() As Variant
Randomize
L = UBound(InArray) - LBound(InArray) + 1
ReDim Arr(LBound(InArray) To UBound(InArray))
For N = LBound(InArray) To UBound(InArray)
Arr(N) = InArray(N)
Next N
For N = LBound(InArray) To UBound(InArray)
J = CLng(((UBound(InArray) - N) * Rnd) + N)
Temp = InArray(N)
InArray(N) = InArray(J)
InArray(J) = Temp
Next N
ShuffleArray = Arr
End Function
Sub ShuffleArrayInPlace(InArray() As Variant)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShuffleArrayInPlace
' This shuffles InArray to random order, randomized in place.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim N As Long
Dim Temp As Variant
Dim J As Long
Randomize
For N = LBound(InArray) To UBound(InArray)
J = CLng(((UBound(InArray) - N) * Rnd) + N)
If N <> J Then
Temp = InArray(N)
InArray(N) = InArray(J)
InArray(J) = Temp
End If
Next N
End Sub
Here's yet another take. It generates an array of unique, random longs.
In this example, I use 1 to 100. It does this by using the collection object. Then you can just do a normal loop through each array element in qArray without the need to randomize more than once.
Sub test()
Dim qArray() As Long
ReDim qArray(1 To 100)
qArray() = RandomQuestionArray
'loop through your questions
End Sub
Function RandomQuestionArray()
Dim i As Long, n As Long
Dim numArray(1 To 100) As Long
Dim numCollection As New Collection
With numCollection
For i = 1 To 100
.Add i
Next
For i = 1 To 100
n = Rnd * (.Count - 1) + 1
numArray(i) = numCollection(n)
.Remove n
Next
End With
RandomQuestionArray = numArray()
End Function
I see you have an answer, I was working on this but lost my internet connection. Anyway here is another method.
'// Builds a question bank (make it a hidden sheet)
Sub ResetQuestions()
Const lTotalQuestions As Long = 300 '// Total number of questions.
With Range("A1")
.Value = 1
.AutoFill Destination:=Range("A1").Resize(lTotalQuestions), Type:=xlFillSeries
End With
End Sub
'// Gets a random question number and removes it from the bank
Function GetQuestionNumber()
Dim lCount As Long
lCount = Cells(Rows.Count, 1).End(xlUp).Row
GetQuestionNumber = Cells(Int(lCount * Rnd + 1), 1).Value
Cells(lRandom, 1).Delete
End Function
Sub Test()
Msgbox (GetQuestionNumber)
End Sub
For whatever it's worth here is my stab at this question. This one uses a boolean function instead of numerical arrays. It's very simple yet very fast. The advantage of it, which I'm not saying is perfect, is an effective solution for numbers in a long range because you only ever check the numbers you have already picked and saved and don't need a potentially large array to hold the values you have rejected so it won't cause memory problems because of the size of the array.
Sub UniqueRandomGenerator()
Dim N As Long, MaxNum As Long, MinNum As Long, Rand As Long, i As Long
MinNum = 1 'Put the input of minimum number here
MaxNum = 100 'Put the input of maximum number here
N = MaxNum - MinNum + 1
ReDim Unique(1 To N, 1 To 1)
For i = 1 To N
Randomize 'I put this inside the loop to make sure of generating "good" random numbers
Do
Rand = Int(MinNum + N * Rnd)
If IsUnique(Rand, Unique) Then Unique(i, 1) = Rand: Exit Do
Loop
Next
Sheet1.[A1].Resize(N) = Unique
End Sub
Function IsUnique(Num As Long, Data As Variant) As Boolean
Dim iFind As Long
On Error GoTo Unique
iFind = Application.WorksheetFunction.Match(Num, Data, 0)
If iFind > 0 Then IsUnique = False: Exit Function
Unique:
IsUnique = True
End Function