How to check the key is exists in collection or not - vb6

I want to check collection variable contains the key or not in visual basic 6.0
Below is the collection variable I am having
pcolFields As Collection
and I want to check whether it contains the field Event_Code. I am doing this as below but it not worked for me.
If IsMissing(pcolFields("Event_Code")) = False Then
'Do Something
End If

Here is an example solution with try-catch:
Private Function IsMissing(col As Collection, field As String)
On Error GoTo IsMissingError
Dim val As Variant
val = col(field)
IsMissing = False
Exit Function
IsMissingError:
IsMissing = True
End Function
Use it like this:
Private Sub Form_Load()
Dim x As New Collection
x.Add "val1", "key1"
Dim testkey As String
testkey = "key2"
If IsMissing(x, testkey) Then
Debug.Print "Key is Missing"
Else
Debug.Print "Val is " + x(testkey)
End If
Exit Sub
End Sub
You could also try a to Implement or Subclass the Collection and add a "has" Function

Collections are not useful if you need to check for existence, but they're useful for iteration. However, collections are sets of Variants and so are inherently slower than typed variables.
In nearly every case it's more useful (and more optimal) to use a typed array. If you need to have a keyed collection you should use the Dictionary object.
Some examples of general ways of using typed arrays:
Dim my_array() As Long ' Or whichever type you need
Dim my_array_size As Long
Dim index As Long
Dim position As Long
' Add new item (push)
ReDim Preserve my_array(my_array_size)
my_array(my_array_size) = 123456 ' something to add
my_array_size = my_array_size + 1
' Remove item (pop)
my_array_size = my_array_size - 1
If my_array_size > 0 Then
ReDim Preserve my_array(my_array_size - 1)
Else
Erase my_array
End If
' Remove item (any position)
position = 3 'item to remove
For index = position To my_array_size - 2
my_array(index) = my_array(index + 1)
Next
my_array_size = my_array_size - 1
ReDim Preserve my_array(my_array_size - 1)
' Insert item (any position)
ReDim Preserve my_array(my_array_size)
my_array_size = my_array_size + 1
For index = my_array_size - 1 To position + 1 Step -1
my_array(index) = my_array(index - 1)
Next
my_array(position) = 123456 ' something to insert
' Find item
For index = 0 To my_array_size - 1
If my_array(index) = 123456 Then
Exit For
End If
Next
If index < my_array_size Then
'found, position is in index
Else
'not found
End If
Whilst it may seem like a lot code. It is way faster. Intellisense will also work, which is a bonus. The only caveat is if you have very large data sets, then redim starts to get slow and you have to use slightly different techniques.
You can also use a Dictionary, be sure to include the Microsoft Scripting Runtime reference in your project:
Dim dict As New Dictionary
Dim value As Long
dict.Add "somekey", 123456
dict.Remove "somekey"
value = dict.Item("somekey")
If dict.Exists("somekey") Then
' found!
Else
' not found
End If
Dictionaries like collections just hold a bunch of Variants, so can hold objects etc.

We can check following code into vb.net code
If Collection.ContainsKey(KeyString) Then
'write code
End if
Collection is variable of Dictionary and KeyString is a key string which we need to find into collection

The method from efkah will fail if the Collection contains objects rather than primitive types. Here is a small adjustment:
'Test if a key is available in a collection
Public Function HasKey(coll As Collection, strKey As String) As Boolean
On Error GoTo IsMissingError
Dim val As Variant
' val = coll(strKey)
HasKey = IsObject(coll(strKey))
HasKey = True
On Error GoTo 0
Exit Function
IsMissingError:
HasKey = False
On Error GoTo 0
End Function

Related

array.slice(start, end) in vbscript?

Anyone have a favorite implementation of the standard (e.g. jscript, javascript) array.slice(start,end) function in vbscript?
It seems to be commonly missed (among vbscript programmers anyway) and sharing a good implementation would help. If one doesn't show up, I guess I'll have to answer my own question and write something.
For completeness, this might be a better version:
Function Slice (aInput, Byval aStart, Byval aEnd)
If IsArray(aInput) Then
Dim i
Dim intStep
Dim arrReturn
If aStart < 0 Then
aStart = aStart + Ubound(aInput) + 1
End If
If aEnd < 0 Then
aEnd = aEnd + Ubound(aInput) + 1
End If
Redim arrReturn(Abs(aStart - aEnd))
If aStart > aEnd Then
intStep = -1
Else
intStep = 1
End If
For i = aStart To aEnd Step intStep
If Isobject(aInput(i)) Then
Set arrReturn(Abs(i-aStart)) = aInput(i)
Else
arrReturn(Abs(i-aStart)) = aInput(i)
End If
Next
Slice = arrReturn
Else
Slice = Null
End If
End Function
This avoids a number of issues with the previous answer:
No consideration of objects in the array
Negative start and end values are allowed; they count backwards from the end
If start is higher than end gives a reversed array subset
The (expensive) redim preserve is not necessary since the array is empty
A defined result is returned (Null) if the input is not an array
Uses the built-in function IsArray instead of string manipulation/comparison on the input
This is one I've used in the past:
Function Slice(arr, starting, ending)
Dim out_array
If Right(TypeName(arr), 2) = "()" Then
out_array = Array()
ReDim Preserve out_array(ending - starting)
For index = starting To ending
out_array(index - starting) = arr(index)
Next
Else
Exit Function
End If
Slice = out_array
End Function
Function Slice(arr, starting, ending)
Dim out_array
If Right(TypeName(arr), 2) = "()" Then
out_array = Array()
If ending=UBound(arr)+1 Then
actending=ending-1
ReDim Preserve out_array(actending - starting)
For index = starting To actending
out_array(index - starting) = arr(index)
Next
Else
ReDim Preserve out_array(ending - starting)
For index = starting To ending
out_array(index - starting) = arr(index)
Next
End If
Else
Exit Function
End If
Slice = out_array
End Function

Excel copy/sort data while counting/removing duplicates

Ok so I've searched and searched and can't quite find what I'm looking for.
I have a workbook and what I'm basically trying to do is take the entries from certain ranges (Sheet1 - E4:E12, E14:E20, I4:I7, I9:I12, I14:I17, & I19:I21) and put them in a separate list on Sheet2. I then want the new list on Sheet2 to be sorted by how many times an entry appeared on Sheet1 as well as display the amount.
example http://demonik.doomdns.com/images/excel.png
Obviously as can be seen by the ranges I listed above, this sample is much smaller lol, was just having trouble trying to figure out how to describe everything and figured an image would help.
Basically I am trying to use VBA (the update would be initialized by hitting a button) to copy data from Sheet1 and put all the ranges into one list in Sheet2 that is sorted by how many times it appeared on Sheet1, and then alphabetically.
If a better discription is needed just comment and let me know, I've always been horrible at trying to describe stuff like this lol.
Thanks in advance!
Another detail: I cant have it search for specific things as the data in the ranges on Sheet1 may change. Everything must be dynamic.
I started out with this data
and used the following code to read it into an array, sort the array, and count the duplicate values, then output the result to sheet2
Sub Example()
Dim vCell As Range
Dim vRng() As Variant
Dim i As Integer
ReDim vRng(0 To 0) As Variant
Sheets("Sheet2").Cells.Delete
Sheets("Sheet1").Select
For Each vCell In ActiveSheet.UsedRange
If vCell.Value <> "" Then
ReDim Preserve vRng(0 To i) As Variant
vRng(i) = vCell.Value
i = i + 1
End If
Next
vRng = CountDuplicates(vRng)
Sheets("Sheet2").Select
Range(Cells(1, 1), Cells(UBound(vRng), UBound(vRng, 2))) = vRng
Rows(1).Insert
Range("A1:B1") = Array("Entry", "Times Entered")
ActiveSheet.UsedRange.Sort Range("B1"), xlDescending
End Sub
Function CountDuplicates(List() As Variant) As Variant()
Dim CurVal As String
Dim NxtVal As String
Dim DupCnt As Integer
Dim Result() As Variant
Dim i As Integer
Dim x As Integer
ReDim Result(1 To 2, 0 To 0) As Variant
List = SortAZ(List)
For i = 0 To UBound(List)
CurVal = List(i)
If i = UBound(List) Then
NxtVal = ""
Else
NxtVal = List(i + 1)
End If
If CurVal = NxtVal Then
DupCnt = DupCnt + 1
Else
DupCnt = DupCnt + 1
ReDim Preserve Result(1 To 2, 0 To x) As Variant
Result(1, x) = CurVal
Result(2, x) = DupCnt
x = x + 1
DupCnt = 0
End If
Next
Result = WorksheetFunction.Transpose(Result)
CountDuplicates = Result
End Function
Function SortAZ(MyArray() As Variant) As Variant()
Dim First As Integer
Dim Last As Integer
Dim i As Integer
Dim x As Integer
Dim Temp As String
First = LBound(MyArray)
Last = UBound(MyArray)
For i = First To Last - 1
For x = i + 1 To Last
If MyArray(i) > MyArray(x) Then
Temp = MyArray(x)
MyArray(x) = MyArray(i)
MyArray(i) = Temp
End If
Next
Next
SortAZ = MyArray
End Function
End Result:
Here is a possible solution that I have started for you. What you are asking to be done gets rather complicated. Here is what I have so far:
Option Explicit
Sub test()
Dim items() As String
Dim itemCount() As String
Dim currCell As Range
Dim currString As String
Dim inArr As Boolean
Dim arrLength As Integer
Dim iterator As Integer
Dim x As Integer
Dim fullRange As Range
Set fullRange = Range("E1:E15")
iterator = 0
For Each cell In fullRange 'cycle through the range that has the values
inArr = False
For Each currString In items 'cycle through all values in array, if
'values is found in array, then inArr is set to true
If currCell.Value = currString Then 'if the value in the cell we
'are currently checking is in the array, then set inArr to true
inArr = True
End If
Next
If inArr = False Then 'if we did not find the value in the array
arrLength = arrLength + 1
ReDim Preserve items(arrLength) 'resize the array to fit the new values
items(iterator) = currCell.Value 'add the value to the array
iterator = iterator + 1
End If
Next
'This where it gets tricky. Now that you have all unique values in the array,
'you will need to count how many times each value is in the range.
'You can either make another array to hold those values or you can
'put those counts on the sheet somewhere to store them and access them later.
'This is tough stuff! It is not easy what you need to be done.
For x = 1 To UBound(items)
Next
End Sub
All that this does so far is get unique values into the array so that you can count how many times each one is in the range.

Count number of different values in chosen (large) range in VBA?

How can I count the number of different values (numbers and strings mixed) in a chosen (large) range in VBA?
I think about this in this way:
1. Read in data into one dimensional array.
2. Sort array (quick or merge sort) need to test which
3. Simply count number of different values if sorted array : if(a[i]<>a[i+1]) then counter=counter+1.
Is it the most efficient way to solve this problem?
Edit: I want to do it in Excel.
Here is a VBA Solution
You don't need an Array to get this done. You can also use a collection. Example
Sub Samples()
Dim scol As New Collection
With Sheets("Sheet1")
For i = 1 To 100 '<~~ Assuming the range is from A1 to A100
On Error Resume Next
scol.Add .Range("A" & i).Value, Chr(34) & _
.Range("A" & i).Value & Chr(34)
On Error GoTo 0
Next i
End With
Debug.Print scol.Count
'For Each itm In scol
' Debug.Print itm
'Next
End Sub
FOLLOWUP
Sub Samples()
Dim scol As New Collection
Dim MyAr As Variant
With Sheets("Sheet1")
'~~> Select your range in a column here
MyAr = .Range("A1:A10").Value
For i = 1 To UBound(MyAr)
On Error Resume Next
scol.Add MyAr(i, 1), Chr(34) & _
MyAr(i, 1) & Chr(34)
On Error GoTo 0
Next i
End With
Debug.Print scol.Count
'For Each itm In scol
' Debug.Print itm
'Next
End Sub
Instead of steps 2 and 3, perhaps you could use a Scripting.Dictionary and add each value to the dictionary. Any duplicate entries would cause a runtime error which you could either trap or ignore (resume next). Finally, you could then just return the dictionary's count which would give you the count of unique entries.
Here's a scrap of code I hurriedly threw together:
Function UniqueEntryCount(SourceRange As Range) As Long
Dim MyDataset As Variant
Dim dic As Scripting.Dictionary
Set dic = New Scripting.Dictionary
MyDataset = SourceRange
On Error Resume Next
Dim i As Long
For i = 1 To UBound(MyDataset, 1)
dic.Add MyDataset(i, 1), ""
Next i
On Error GoTo 0
UniqueEntryCount = dic.Count
Set dic = Nothing
End Function
I know that resume next can be considered a 'code smell', but the alternative could be to use the exists function of the dictionary to test whether the specified key already exists and then add the value if did not. I just have a feeling that when I did a similar thing in the past that it was faster to just ignore any errors raised for duplicate keys rather than using exists YMMY. For completeness, here's the other method using exists:
Function UniqueEntryCount(SourceRange As Range) As Long
Dim MyDataset As Variant
Dim dic As Scripting.Dictionary
Set dic = New Scripting.Dictionary
MyDataset = SourceRange
Dim i As Long
For i = 1 To UBound(MyDataset, 1)
if not dic.Exists(MyDataset(i,1)) then dic.Add MyDataset(i, 1), ""
Next i
UniqueEntryCount = dic.Count
Set dic = Nothing
End Function
Whilst the above code is simpler than your proposed method, it would be worth to test the performance of it against your solution.
Building on the idea presented by i_saw_drones, I strongly recommend the Scripting.Dictionary. However, this can be done without On Error Resume Next as shown below. Also, his example requires linking the Microsoft Scripting Runtime library. My example will demonstrate how to do this without needing to do any linking.
Also, since you're doing this in Excel, then you don't need to create the array in step 1 at all. The function below will accept a range of cells, which will be iterated through completely.
(i.e. UniqueCount = UniqueEntryCount(ActiveSheet.Cells) or UniqueCount = UniqueEntryCount(MySheet.Range("A1:D100"))
Function UniqueEntryCount(SourceRange As Range) As Long
Dim MyDataset As Variant
Dim MyRow As Variant
Dim MyCell As Variant
Dim dic As Object
Dim l1 As Long, l2 As Long
Set dic = CreateObject("Scripting.Dictionary")
MyDataset = SourceRange
For l1 = 1 To UBound(MyDataset)
' There is no function to get the UBound of the 2nd dimension
' of an array (that I'm aware of), so use this division to
' get this value. This does not work for >=3 dimensions!
For l2 = 1 To SourceRange.Count / UBound(MyDataset)
If Not dic.Exists(MyDataset(l1, l2)) Then
dic.Add MyDataset(l1, l2), MyDataset(l1, l2)
End If
Next l2
Next l1
UniqueEntryCount = dic.Count
Set dic = Nothing
End Function
It might also be important to note that the above will count a null string "" as a distinct value. If you do not want this to be the case, simply change the code to this:
For l1 = 1 To UBound(MyDataset)
For l2 = 1 To SourceRange.Count / UBound(MyDataset)
If Not dic.Exists(MyDataset(l1, l2)) And MyDataset(l1, l2) <> "" Then
dic.Add MyDataset(l1, l2), MyDataset(l1, l2)
End If
Next l2
Next l1
Sorry this is written in C#. This is how I would do it.
// first copy the array so you don't lose any data
List<value> copiedList = new List<value>(yourArray.ToList());
//for through your list so you test every value
for (int a = 0; a < copiedList.Count; a++)
{
// copy instances to a new list so you can count the values and do something with them
List<value> subList = new List<value>(copiedList.FindAll(v => v == copiedList[i]);
// do not do anything if there is only 1 value found
if(subList.Count > 1)
// You would want to leave 1 'duplicate' in
for (int i = 0; i < subList.Count - 1; i++)
// remove every instance from the array but one
copiedList.Remove(subList[i]);
}
int count = copiedList.Count; //this is your actual count
Have not tested it, please try.
You should wrap this inside a method so there is no messing around with the garbage. Otherwise you would lose the copy of the array only later. (return count)
EDIT: You need a list for this to work, use Array.ToList();

How do I declare global array in VBScript

I'm trying to store an array value so that I can reuse when Sub is called more than once.
I would like to prevent from reassigning values to the array if value exist.
My code is something like this.
Dim views()
Sub runit()
For i=0 To 3
test()
Next
End Sub
Sub test()
ReDim Preserve views(0)= "test"
' - other codes that I want to run-
End Sub
I get " Type mismatch :'choseviews'" error.
If I move "Dim views()" inside "Sub test", I don't get the error.
How do I declare global array in VBScript?
If it's not possible, is there any ways to prevent reassigning array when Sub is called?
This following code does not work but you may get an idea what I'm trying to do .
Dim views()
Sub runit()
For i=0 To 3
test()
Next
End Sub
Function IsArrayDimmed(arr)
IsArrayDimmed = False
If IsArray(arr) Then
On Error Resume Next
Dim ub : ub = UBound(arr)
If (Err.Number = 0) And (ub >= 0) Then IsArrayDimmed = True
End If
End Function
Sub test()
If IsArrayDimmed(views) Then
Else
ReDim Preserve views(0)= "test"
End If
' - other codes that I want to run-
End Sub
Thank you for your help.
If I understand correctly, it seems like you want to declare a global array variable, and then add items to that array, without being limited to a static number of elements. In other words, you need to dynamically increase the size of the array by re-allocating it.
The global declaration is correct and belongs where you have it:
Dim views()
What you wrote here is incorrect syntax, you cannot assign a value and ReDim at the same time.:
ReDim Preserve views(0)= "test"
Additionally, that would ReDim the array to size 0, which is the opposite of what you want.
If you wish to "push" values on that array you should use a function like this which handles the redim to increase the size of the array before adding the value to the tail of the array:
Function Push(ByRef arrTarget, ByVal varValue)
Dim intCounter
Dim intElementCount
ReDim Preserve arrTarget(UBound(arrTarget) + 1)
If (isObject(varValue)) Then
Set arrTarget(UBound(arrTarget)) = varValue
Else
arrTarget(UBound(arrTarget)) = varValue
End If
Push = arrTarget
End Function
Use it like this:
Call Push(views,"test")
Any variable instantiated in the global scope will be a "global" variable. However, you should pass that variable explicitly into other scopes "by reference" if you want to have any changes persist in the original scope. You can do that using the ByRef keword in your Function or Sub declaration.
Sub test(ByRef viewsArray)
Now within test you will reference viewsArray which acts as a pointer to views.

Random selection from list

I have a list of items in an Excel worksheet, A1-B115. At the moment I can enter 10 variables which retrieves the correct data from the list.
Code now:
C1=1 - run through A1-A115 and check for the value to be between 1000-2000; if so, copy the B value somewhere.
C2=1 - run through A1-A115 and check for the value to be between 2001-3000; if so, copy the B value somewhere.
....
What I would like to do is that I can enter a value (example: 25 or 30) and that my macro randomly selects the right amount of values.
Code I would like to do: C1: 30 -> randomly selects 30 values from B1-B115
This will do the trick.
Sub PickRandomItemsFromList()
Const nItemsToPick As Long = 10
Const nItemsTotal As Long = 115
Dim rngList As Range
Dim varRandomItems() As Variant
Dim i As Long
Set rngList = Range("B1").Resize(nItemsTotal, 1)
ReDim varRandomItems(1 To nItemsToPick)
For i = 1 To nItemsToPick
varRandomItems(i) = rngList.Cells(Int(nItemsTotal * Rnd + 1), 1)
Next i
' varRandomItems now contains nItemsToPick random items from range rngList.
End Sub
As discussed in the comments, this will allow individual items to be picked more than once within the nItemsToPick picked, if for example number 63 happens to be randomly picked twice. If you don't want this to happen, then an additional loop will have to be added to check whether the item about to be picked is already in the list, for example like so:
Sub PickRandomItemsFromList()
Const nItemsToPick As Long = 10
Const nItemsTotal As Long = 115
Dim rngList As Range
Dim idx() As Long
Dim varRandomItems() As Variant
Dim i As Long
Dim j As Long
Dim booIndexIsUnique As Boolean
Set rngList = Range("B1").Resize(nItemsTotal, 1)
ReDim idx(1 To nItemsToPick)
ReDim varRandomItems(1 To nItemsToPick)
For i = 1 To nItemsToPick
Do
booIndexIsUnique = True ' Innoncent until proven guilty
idx(i) = Int(nItemsTotal * Rnd + 1)
For j = 1 To i - 1
If idx(i) = idx(j) Then
' It's already there.
booIndexIsUnique = False
Exit For
End If
Next j
If booIndexIsUnique = True Then
Exit Do
End If
Loop
varRandomItems(i) = rngList.Cells(idx(i), 1)
Next i
' varRandomItems now contains nItemsToPick unique random
' items from range rngList.
End Sub
Note that this will loop forever if nItemsToPick > nItemsTotal !
I would use a collection to make sure you don't get any duplicates.
Function cItemsToPick(NrOfItems As Long, NrToPick As Long) As Collection
Dim cItemsTotal As New Collection
Dim K As Long
Dim I As Long
Set cItemsToPick = New Collection
If NrToPick > NrOfItems Then Exit Function
For I = 1 To NrOfItems
cItemsTotal.Add I
Next I
For I = 1 To NrToPick
K = Int(cItemsTotal.Count * Rnd + 1)
cItemsToPick.Add cItemsTotal(K)
cItemsTotal.Remove (K)
Next I
Set cItemsTotal = Nothing
End Function
You can test this function with the following code:
Sub test()
Dim c As New Collection
Dim I As Long
Set c = cItemsToPick(240, 10)
For I = 1 To c.Count
Debug.Print c(I)
Next I
End Sub

Resources