Non repeating positive random numbers, over a given range - vb6

am generating a game using vb 6.0, at one face i need to generate non repeating random numbers between 1 and 100. am using the following code for generating the random numbers
dim n(10) as integer
for i=0 to 9
n(i)=round(rnd*100)
next i
the code is within a for loop hence it generate 10 Nos. randomly, but it includes repeating numbers and also '0', is their any suggestion to avoid repeating numbers and '0'
then output of my code is:
n()={42,14,10,22,5,42,12,0,59,72}
the numbers 42 is appear two times in the array and 0 cannot be avoided
thanks in advance

Here is a simple technique
Dim n(10) As Integer
Dim choice(100) As Integer
' Create a list of possible numbers
For i = 0 To 100
choice(i) = i
Next
' Populate the array with unique numbers
For i = 1 To 10
lastix = 101 - i
' Find one that has not been selected
ix = Round(Rnd * lastix)
' Assign it
n(i) = choice(ix)
' Replace with one that has not been used
choice(ix) = choice(lastix)
Next
You can use the same technique for shuffling cards.

To avoid 0, multiply by 99 and add 1. To avoid duplicates, keep track of what you generated and retry if you get a duplicate. (Since you need only a few numbers. If you need many, shuffle an array of all possible outcomes and take the initial members.)

the solution below is not the fastest, but makes up by that for being easy ...
it uses a hidden listbox control which contains the required values and retreives a random one every time
the values in this example are just the squared numbers of the index
run the project and click the command button to see what happens. it should show messageboxes with the square numbers in random order
'1 form with:
'1 listbox control : name=List1
'1 command button : name=Command1
Option Explicit
Private Sub Command1_Click()
Dim intIndex As Integer
'generate a new random sequence every time
Randomize Timer
'loop through the list and retreive 1 random value at a time
With List1
Do While .ListCount > 0
intIndex = Int(Rnd * .ListCount)
MsgBox .List(intIndex)
'remove the used item from the list
.RemoveItem intIndex
Loop
End With 'List1
End Sub
Private Sub Form_Load()
Dim intIndex As Integer
'hide listbox
List1.Visible = False
'fill listbox with values (squares)
List1.Clear
For intIndex = 1 To 10
List1.AddItem CStr(intIndex * intIndex)
Next intIndex
End Sub
btw i am just using 10 numbers so you dont have to click through 100 messageboxes :)

Related

Make a macro to sort a row using a custom list in LibreOffice Calc

I need to sort a column containing cells with the following format : "TITLE text". I know the list of possible titles, but not the texts, so what I would like to do is sort the title in a custom order (for example : PLA, ARG, FHI, BRT) that is not alphabetical. The problem is that the title and the text are in the same cell.
So, for example, here is a screen of datas I might want to work on :
How can I sort this if the cells doesn't perfectly match the list members ?
And, if possible, how to do that using a macro and not manually ?
It's not very difficult. I will try to explain how this is done.
First of all, we need to figure out a way to transfer the range of cells to be sorted to the macro. There are different ways - write the address directly in the macro code, pass it as a parameter to the UDF, get it from the current selection. We use the third method - it is not the easiest to code, but it will work with any data sets.
The main difficulty when using the current selection is that the selection can be one single cell (nothing to sort), a range of cells (and may be several columns - how to sort this?) or several ranges of cells (this is if you hold down the CTRL key and select several unconnected ranges).
A good macro should handle each of these situations. But now we are not writing a good macro, we are getting acquainted with the principle of solving such problems (Since StackOfflow is a resource for programmers, the answers here help you write code yourself, and not get ready-made programs for free). Therefore, we will ignore a single cell and
multiple ranges - we will just stop execution of macro. Moreover, if there is more than one column in the selected range, then we will not do anything either.
Also, in case a full column is selected, we restrict the range to be sorted to the used area. This will sort the real data, but not the million empty cells.
The code that does all this looks like this:
Sub SortByTitles()
Dim oCurrentSelection As Variant
Dim oSortRange As Variant
Dim oSheet As Variant
Dim oCursor As Variant
Dim oDataArray As Variant
Dim sList As String
sList = "PLA,ARG,FHI,BRT"
oCurrentSelection = ThisComponent.getCurrentSelection()
Rem Is it one singl cell?
If oCurrentSelection.supportsService("com.sun.star.sheet.SheetCell") Then Exit Sub
Rem Is it several ranges of cells?
If oCurrentSelection.supportsService("com.sun.star.sheet.SheetCellRanges") Then Exit Sub
Rem Is this one range of cells? (It can be a graphic item or a control.
Rem Or it may not even be a Calc spreadsheet at all)
If Not oCurrentSelection.supportsService("com.sun.star.sheet.SheetCellRange") Then Exit Sub
Rem Is there only one column selected?
If oCurrentSelection.getColumns().getCount() <> 1 Then Exit Sub
Rem Is the current selection outside of the used area?
oSheet = oCurrentSelection.getSpreadsheet()
oCursor = oSheet.createCursor()
oCursor.gotoEndOfUsedArea(True)
oSortRange = oCursor.queryIntersection(oCurrentSelection.getRangeAddress())
If oSortRange.getCount() <> 1 Then Exit Sub
Rem Redim oSortRange as single range (not any ranges)
oSortRange = oSortRange.getByIndex(0)
Rem Get data from oSortRange
oDataArray = oSortRange.getDataArray()
Rem Paste sorted data to the same place:
oSortRange.setDataArray(getSorted(oDataArray, Split(sList,",")))
End Sub
The getSorted() function, which is mentioned in the last line of the procedure, must take two arrays as parameters — the values ​​of the cells to be sorted and the sort list — and return one array of sorted values.
One aspect of working with data from ranges of cells should be mentioned here. If in Excel after receiving data from the range we get a two-dimensional array, then in OpenOffice/LibreOffice we get a one-dimensional "array of arrays", each element of which is a one-dimensional array of cell values ​​of one row. Writing to a range is done from exactly the same structure, from an "array of arrays". The first parameter of the getSorted() function is oDataArray - just such an array of arrays, this will need to be taken into account when processing data.
What will getSorted() function do? It will build a "tree" sorted by Headers from the oDataArray values. In fact, this is not a tree - it is an ascending sorted array of all Headers and all values ​​with these Headers. The values ​​are also a sorted array. Then the function will select from the tree those Headings that are listed in the List and remove them from the tree. If, after all the actions, some elements still remain in the sorted tree, they will be displayed at the very end.
The function will accumulate the result in a separate array of the same size as the original one. In other words, the algorithm will use three times more memory than the original sorted range - source data, a tree and result array. The function will accumulate the result in a separate array of the same size as the original one. In other words, the algorithm will use three times more memory than the original sorted range - source data, a tree and result array.
You can try to save resources and write the results directly to the original array. But I strongly advise against doing this.
The fact is that an array cell may contain not a value, but a reference to a value, and in the case of inaccurate coding, you will not get a large sorted array, but a large array of the same value (the last cell).
I deliberately do not comment on all the following code - if you can read and understand this without comment, then you will understand how actions are programmed to process data from ranges:
Function getSorted(aData As Variant, aList As Variant) As Variant
Dim aRes As Variant
Dim i As Long, pos As Long, j As Long, k As Long, m As Long, uB As Long
Dim aTemp As Variant
aTemp = Array()
ReDim aRes(LBound(aData) To UBound(aData))
For i = LBound(aData) To UBound(aData)
pos = InStr(aData(i)(0), " ")
If pos > 0 Then
AddToArray(Left(aData(i)(0),pos-1), aData(i)(0), aTemp)
Else
AddToArray(aData(i)(0), aData(i)(0), aTemp)
EndIf
Next i
m = LBound(aData) - 1
For i = LBound(aList) To UBound(aList)
k = getIndex(aList(i), aTemp)
If k > -1 Then
uB = UBound(aTemp) - 1
For j = LBound(aTemp(k)(1)) To UBound(aTemp(k)(1))
m = m + 1
aRes(m) = Array(aTemp(k)(1)(j))
Next j
For j = k To uB
aTemp(j) = aTemp(j+1)
Next j
ReDim Preserve aTemp(uB)
EndIf
Next i
For k = LBound(aTemp) To UBound(aTemp)
For j = LBound(aTemp(k)(1)) To UBound(aTemp(k)(1))
m = m + 1
aRes(m) = Array(aTemp(k)(1)(j))
Next j
Next k
getSorted = aRes
End Function
To build a sorted tree, two subroutines are used - AddToArray() and InsertToArray(). They are very similar - the first eight lines are a normal binary search, and the remaining 10-12 lines are actions when an element is not found at the end of the array, when it is found and when it is not found in the middle of the array:
Sub AddToArray(key As Variant, value As Variant, aData As Variant)
Dim l&, r&, m&, N&, i&
l=LBound(aData)
r=UBound(aData)+1
N=r
While (l<r)
m=l+Int((r-l)/2)
If aData(m)(0)<key Then
l=m+1
Else
r=m
EndIf
Wend
If r=N Then
ReDim Preserve aData(0 To N)
aData(N) = Array(key, Array(value))
ElseIf aData(r)(0)=key Then
InsertToArray(value, aData(r)(1))
Else
ReDim Preserve aData(0 To N)
For i = N-1 To r Step -1
aData(i+1)=aData(i)
Next i
aData(r) = Array(key, Array(value))
EndIf
End Sub
Sub InsertToArray(key As Variant, aData As Variant)
Dim l&, r&, m&, N&, i&
l=LBound(aData)
r=UBound(aData)+1
N=r
While (l<r)
m=l+Int((r-l)/2)
If aData(m)<key Then
l=m+1
Else
r=m
EndIf
Wend
If r=N Then
ReDim Preserve aData(0 To N)
aData(N) = key
Else
ReDim Preserve aData(0 To N)
For i = N-1 To r Step -1
aData(i+1)=aData(i)
Next i
aData(r) = key
EndIf
End Sub
The getIndex() function uses the same binary search. It will return the index of the element in the array if it can find it, or -1 otherwise:
Function getIndex(key As Variant, aData As Variant) As Long
Dim l&, r&, m&, N&
l=LBound(aData)
r=UBound(aData)+1
N=r
While (l<r)
m=l+Int((r-l)/2)
If aData(m)(0)<key Then
l=m+1
Else
r=m
EndIf
Wend
If r=N Then
getIndex = -1
ElseIf aData(r)(0)=key Then
getIndex = r
Else
getIndex = -1
EndIf
End Function
And that's all that is needed to solve the task:
Demo file with code - SortByTitle.ods

Iterate over all selected rows of SSDBGrid to fill an array

I need to iterate over all of the selected rows in an SSDBGrid. Then, I need to get the value in the current row and populate the relevant place in the array with this value.
I've been attempting to do this with the code below:
Dim i As Integer
i = 0
Dim nomCode(Grd_Nominal.SelBookmarks.Count) As String ' This is my array.
Do While Grd_Nominal.SelBookmarks <> 0
nomCode(i) = Grd_Nominal.SelBookmarks(0)
If Grd_Nominal.SelBookmarks.Count > 0 Then
Grd_Nominal.SelBoomarks(0).Remove
End If
i = i + 1
Loop
However, nomCode(i) is always being filled as nomCode(i) = "??"
Why is it inserting "??", and how can I fix this to insert the value of the current row?
You need to first of all re-think how you're declaring your array.
Dim nomCode() As String
ReDim nomCode(Grd_Nominal.SelBookmarks.Count - 1) As String
This is because when declaring an array you need to pass in a constant as the length. ReDim doesn't, so this will go partly towards solving the issue.
Dim x As Integer
Dim bk As Variant
For x = 0 to Grd_Nominal.Rows.Count - 1
bm = Grd_Nominal.SelBookmarks(x)
nomCode(x) = Grd_Nominal.Columns("Your_Column").CellValue(bm)
Next
This should sort the rest of the issue, I think.

I am trying to get 6 separate input numbers from the user for my program using one textbox

I have been trying to use a textbox in VB6 to acquire 6 different random numbers chosen by the user to use in part of my program. I have tried many different approaches in different areas of the code. Best I have gotten so far is in the keypress section. I set up an array to store the 6 entries buy fail to be able to get past storing one number in the first element. I'm using a for next loop to cycle through the elements but the textbox.setfocus will not work properly in the loop. I clear the box then setfocus after I assign the number to an element in the array. The only other way I'm thinking this would work is to hide the single box and show 6 hidden ones and then they can tab or I can hide each one again as they fill up.
Here's a snip of that code so one should get an idea what I'm trying to do here.
Private Sub Inbox_Keypress(KeyAscii As Integer)
Select Case KeyAscii ' Determine keypress
Case vbKey0 To vbKey9 'Only the numbers
Case vbKeyBack, vbKeyClear, vbKeyDelete ' Accept these keys
Case vbKeyLeft, vbKeyRight ' Arrow keys
Case 13 ' Enter
If GenOpt(5).Value = True Then
For c = 1 To 6
Gen6_user(c) = Inbox.Text
'Select Case KeyAscii
' Case 13
Talkbox.Caption = "Please enter the next user number for Generator 6"
'Case Else
' MsgBox Msg, style, title
'End Select
If c = 6 Then Exit For
Do
Inbox.Text = ""
Inbox.SetFocus
Loop Until KeyAscii = 13
Next
For c = 1 To 6
Msg6.Print Gen6_user(c)
Next
Else
User_number = Inbox.Text ' Assign any final value to User_number variabl)
Generate.SetFocus
'Generate_Click ' Call generate function
End If
Any help would be appreciated
Journey
I am at work and I don't have VB6 handy here... but, this should work (maybe with a few little tweaks, I am sure you can figure those out):
Dim x As Integer = 1
Dim myArray(6) As Integer
Private Sub TextBox1_KeyUp(KeyCode As Integer)
If KeyCode = 13 Then
myArray(x) = TextBox1.Text
x = x + 1
TextBox1.Text = ""
End If
If x = 6 Then
Debug.Print("Here you check your numbers?")
End If
End Sub

Excel VBA: Writing an array to cells is very slow

I am working with VBA in Excel to retrieve some information from the Reuters 3000 Database. The data I retrieve comes as a bidimensional array consisting of one column holding dates and other column holding numeric values.
After I retrieve the information, a process that takes no more than 2 seconds, I want to write this data to a worksheet. In the worksheet I have a column with dates and several other columns with numeric values, each column containing values of a same category. I iterate over the rows of the array to get the date and numeric value and I keep those in a variable, then I search for the date on the date column of the worksheet and after I've found the date I write the value. Here is my code:
Private Sub writeRetrievedData(retrievedData As Variant, dateColumnRange As String, columnOffset As Integer)
Dim element As Long: Dim startElement As Long: Dim endElement As Long
Dim instrumentDate As Variant: Dim instrumentValue As Variant
Dim c As Variant: Dim dateCellAddress As Variant
Application.ScreenUpdating = False
Sheets("Data").Activate
startElement = LBound(retrievedData, 1): endElement = UBound(retrievedData, 1)
Application.DisplayStatusBar = True
Application.StatusBar = "Busy writing data to worksheet"
For element = startElement To endElement
instrumentDate = retrievedData(element, 1): instrumentValue = retrievedData(element, 2)
Range(dateColumnRange).Select
Set c = Selection.Find(What:=instrumentDate, After:=ActiveCell, LookIn:=xlValues, _
LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not c Is Nothing Then
c.offset(0, columnOffset).Value = instrumentValue
End If
Next element
Application.DisplayStatusBar = False
End Sub
My problem is that this process is very slow, even if I have only 5 rows in the array it takes about 15 seconds to complete the task. As I want to repeat this process several times (once per each set of data I retrieve from the database), I would like to decrease the execution time as much as possible.
As you can see, I am disabling the update of the screen, which is one of the most recurrent actions to improve performance. Does anybody have a suggestion on how I can further decrease the execution time?
PS. I know the data retrieval process does not take much because I already tested that part (displaying values on a MsgBox as soon as the data has been retrieved)
Thanks in advanced.
This is what I did to improve the performance:
Avoid selecting the cell when the value is going to be written. This was a suggestion of Tim Williams.
I set the property Application.Calculation to xlCalculationManual
Instead of using the Find() function to search for the date, I loaded all the dates from the worksheet into an array and iterate over this array to get the row number. This turns out to be faster than the Find() function.
Private Function loadDateArray() As Variant
Dim Date_Arr() As Variant
Sheets("Data").Activate
Date_Arr = Range(Cells(3, 106), Cells(3, 106).End(xlDown))
loadDateArray = Date_Arr
End Function
Private Function getDateRow(dateArray As Variant, dateToLook As Variant)
Dim i As Double: Dim dateRow As Double
For i = LBound(dateArray, 1) To UBound(dateArray, 1)
If dateArray(i, 1) = dateToLook Then
dateRow = i
Exit For
End If
Next i
getDateRow = dateRow
End Function
Thank you all for your help!
By not selecting the sheet, you can add a bit more speed. Instead of
Sheets("Data").Activate
Date_Arr = Range(Cells(3, 106), Cells(3, 106).End(xlDown))
loadDateArray = Date_Arr
Try
With Sheets("Data")
Date_Arr = .Range(Cells(3, 106), Cells(3, 106).End(xlDown))
End With

VB: Declaring variables in For loop

I have been trying to declare variables inside a For loop for quite some time now, and I just haven't been able to find a way.
I'm attempting to create a new image (tile) for every time a certain number is encountered in a two-dimensioned array (Measuring 32x16). I may need to add in that I am using Visual Basic 6.
Currently I'm using the following code:
Option Explicit
Dim wCount As Integer
Dim hCount As Integer
Dim arrTiles(31, 15) As Integer
Private Sub Form_Load()
For wCount = 0 To 31 Step 1
For hCount = 0 To 15 Step 1
' -Declare variables
' -I.E. Dim NAME As Image
Next
Next
End Sub
However, the above code (Using Dim tile1 As Image) gives me an error whenever trying to access one of the properties of the newly added image (Such as tile1.Width).
Is there any way to declare a variable this way at run-time?
Sincerely
- Birjolaxew
You must assign a valid Image object to the Image variable before you try to access any properties of it. For example, this works fine:
For wCount = 0 To 31 Step 1
For hCount = 0 To 15 Step 1
' -Declare variables
Dim tile1 As Image
tile1 = Image.FromFile("c:/test.png")
Dim width = tile1.Width
Next
Next

Resources