I'm trying to add a list of names from another worksheet that has duplicates. On the listbox, I want to have unique names, instead of duplicates. The following code is not sorting them for duplicates, it errors out. Any help is appreciated.
Dim intCount As Integer
Dim rngData As Range
Dim strID As String
Dim rngCell As Range
dim ctrlListNames as MSForms.ListBox
Set rngData = Application.ThisWorkbook.Worksheets("Names").Range("A").CurrentRegion
'declare header of strID and sort it
strID = "Salesperson"
rngData.Sort key1:=strID, Header:=xlYes
'Loop to add the salesperson name and to make sure no duplicates are added
For Each rngCell In rngData.Columns(2).Cells
If rngCell.Value <> strID Then
ctrlListNames.AddItem rngCell.Value
strID = rngCell.Value
End If
Next rngCell
Way 1
Use this to remove the duplicates
Sub Sample()
RemovelstDuplicates ctrlListNames
End Sub
Public Sub RemovelstDuplicates(lst As msforms.ListBox)
Dim i As Long, j As Long
With lst
For i = 0 To .ListCount - 1
For j = .ListCount - 1 To (i + 1) Step -1
If .List(j) = .List(i) Then
.RemoveItem j
End If
Next
Next
End With
End Sub
Way 2
Create a unique collection and then add it to the listbox
Dim Col As New Collection, itm As Variant
For Each rngCell In rngData.Columns(2).Cells
On Error Resume Next
Col.Add rngCell.Value, CStr(rngCell.Value)
On Error GoTo 0
Next rngCell
For Each itm In Col
ctrlListNames.AddItem itm
Next itm
Private Sub Workbook_Open()
Dim ctrlListNames As MSForms.ListBox
Dim i As Long
Dim j As Long
ctrlListNames.List = Application.ThisWorkbook.Worksheets("Names").Range("Salesperson").Value
With ctrlListNames
For i = 0 To .ListCount - 1
For j = .ListCount To (i + 1) Step -1
If .List(j) = .List(i) Then
.RemoveItem j
End If
Next
Next
End With
End Sub
And it says invalid property array index.
It says invalid property array index because the list gets shortened after the removal of entries. if we use FOR, the end value is static, therefore, we need to use DO while loop. Use the following code to remove duplicates.
Count = ListBox1.ListCount - 1
i = 0
j = 0
Do While i <= Count
j = i + 1
Do While j <= Count
If ListBox1.List(i) = ListBox1.List(j) Then
ListBox1.RemoveItem (j)
Count = ListBox1.ListCount - 1 'Need to update list count after each removal.
End If
j = j + 1
Loop
i = i + 1
Loop
Related
Solved my own problem. I needed to first check if column 2 cells were empty and if so delete said row. This caused issues due to last row of table being merged across. I then needed to add rows below first row, to maintain 4 columns in each row, in table based on user selection of ArraySize in userform. Then populate first cell in each row with a docvariable in userform followed by incrementing number in each row. Then sort table in descending order. Here is my code for future use.
Private Sub cbArraySize_Click()
If cbArraySize.Value <> 0 Then
DeleteRows
AddRows
AddArrayName
TableSort
End If
End Sub
Sub DeleteRows()
Dim tbl As Word.Table
Dim nrRows As Long, ColToCheck As Long, i As Long
Dim cellRange As Word.Range
Set tbl = ActiveDocument.Tables(2)
nrRows = tbl.Rows.Count - 1
ColToCheck = 2
For i = nrRows To 1 Step -1
Set cellRange = tbl.Cell(i, ColToCheck).Range
If Len(cellRange.Text) = 2 Then
cellRange.Rows(1).Delete
End If
Next i
End Sub
Sub AddRows()
With ActiveDocument
.Tables(2).Rows(1).Select
Selection.InsertRowsBelow (cbArraySize.Value)
End With
End Sub
Sub AddArrayName()
With ActiveDocument
Dim tbl As Object
Dim noOfCol As Integer
Dim i As Long
Dim intcount As Integer
Set tbl = .Tables(2)
With tbl
noOfCol = tbl.Range.Rows(1).Cells.Count
For i = .Rows.Count To 1 Step -1
With .Rows(i)
If Len(.Range) = noOfCol * 2 + 2 Then .Cells(1).Range.InsertAfter Text:=tbArrayName.Text + " - " & intcount
intcount = intcount + 1
End With
Next i
End With
End With
End Sub
Sub TableSort()
ActiveDocument.Tables(2).Sort ExcludeHeader:=True
End Sub
Posted my working code in original post.
I have created a collection of data, and am trying to work with it, and remove items as necessary. Below is my code, and please tell if it is possible to loop through the same collection multiple times at the same time..
I save the first item to a variable, in order to use as reference when searching through the collection. If there is a match then the counter increases, and when the counter is 2 and above I then search the collection to remove the same item from the entire collection. I think the way I have written the code is self explanatory with what I am trying to achieve. If items exist more than once in the collection they need to be removed.
I am getting a runtime error '9' where is set:
tempStorageB = EScoll(j)
I am unsure as to why this is occurring so any guidance/ help is appreciated!
Dim i as Long, j as Long, k as Long
Dim EScoll As New Collection
Dim tempStorageA as Variant
Dim tempStorageB as Variant
Dim tempStorageC as Variant
Dim counter as Integer
For i = 1 To EScoll.Count
tempStorageA = EScoll(i)
'counter loop
For j = 1 To EScoll.Count
tempStorageB = EScoll(j)
If tempStorageB = tempStorageA Then
counter = counter + 1
If counter >= 2 Then
'remove all duplicates from collection loop
For k = EScoll.Count To 1 Step -1
tempStorageC = EScoll(k)
If tempStorageC = tempStorageA Then
EScoll.Remove k
End If
Next k
End If
End If
Next j
Next i
For i = 1 To EScoll.Count
Debug.Print EScoll(i)
Next i
Here is a solution that will remove duplicates from a Collection.
Because of the iterative nature of the search, you have to search and remove one at a time. While this is rather inefficient, the Collection object does not lend itself to being efficient for these operations.
Option Explicit
Sub test()
Dim i As Long, j As Long, k As Long
Dim EScoll As New Collection
PopulateCollection EScoll
Dim duplicatesFound As Boolean
Do
duplicatesFound = False
Dim checkItem As Long
For checkItem = 1 To EScoll.Count
Dim dupIndex As Long
dupIndex = DuplicateItemExists(EScoll, EScoll.Item(checkItem))
If dupIndex > 0 Then
duplicatesFound = True
EScoll.Remove (dupIndex)
'--- kick out of this loop and start again
Exit For
End If
Next checkItem
Loop Until Not duplicatesFound
Debug.Print "dupes removed, count = " & EScoll.Count
End Sub
Function DuplicateItemExists(ByRef thisCollection As Collection, _
ByVal thisValue As Variant) As Long
'--- checks to see if two items have the same given value
' RETURNS the duplicate index number
Dim valueCount As Long
valueCount = 0
Dim i As Long
DuplicateItemExists = 0
For i = 1 To thisCollection.Count
If thisCollection.Item(i) = thisValue Then
valueCount = valueCount + 1
If valueCount > 1 Then
DuplicateItemExists = i
Exit Function
End If
End If
Next i
End Function
Sub PopulateCollection(ByRef thisCollection As Collection)
Const MAX_ITEMS As Long = 50
Dim i As Long
For i = 1 To MAX_ITEMS
thisCollection.Add CLng(Rnd(10) * 10)
Next i
End Sub
Your populating is in same sub, I would delete your duplicates during (just after)
adding)
Sub tsttt()
Dim EScoll As New Collection
Dim DoublesColl As New Collection
Dim x
With EScoll
For Each x In Range("a1:a10").Value 'adjust to your data
On Error Resume Next
.Add x, Format(x)
If Err.Number <> 0 Then
DoublesColl.Add x, Format(x)
On Error GoTo 0
End If
Next
For Each x In DoublesColl
.Remove Format(x)
Next
End With
End Sub
Just to show the solution (for future reference for anyone who has a similar problem) I have come up with the new understanding of the cause of the initial error. The problem being that once setting the count of the for loop to the count of the collection it would not change after an item was deleted. A simple and effective solution for me was to loop through in a similar fashion as above, however, instead of using .Remove I added all the values that were unique to a new collection. See below:
Dim SPcoll As New Collection
For i = 1 To EScoll.Count
tempStorageA = EScoll(i)
counter = 0
For j = 1 To EScoll.Count
tempStorageB = EScoll(j)
If tempStorageB = tempStorageA Then
counter = counter + 1
End If
Next j
If counter < 2 Then
SPcoll.Add tempStorageA
End If
Next i
SPcoll now contains all unique items from previous collection!
I am trying to make a queue which is able to show the first in first out concept. I want to have an array which works as a waiting list. The patients who come later will be discharged later. There is a limitation of 24 patients in the room the rest will go to a waiting list. whenever the room is empty the first patients from the waiting room (the earliest) goes to the room. Here is the code that I have come up with so far. Any help is greatly appreciated.
Dim arrayU() As Variant
Dim arrayX() As Variant
Dim arrayW() As Variant
Dim LrowU As Integer
Dim LrowX As Integer
Dim LrowW As Integer
'Dim i As Integer
Dim j As Integer
Dim bed_in_use As Integer
LrowU = Columns(21).Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LrowX = Columns(24).Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
LrowW = Columns(23).Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
ReDim arrayU(1 To LrowU)
ReDim arrayX(1 To LrowX)
ReDim arrayW(1 To LrowW)
For i = 3 To LrowU
arrayU(i) = Cells(i, 21)
Next i
i = 3
For i = 3 To LrowX
arrayX(i) = Cells(i, 24)
Next i
i = 3
j = 3
For r = 3 To LrowW
arrayW(r) = Cells(r, 23)
Next r
r = 3
i = 3
j = 3
For i = 3 To LrowX ' the number of bed in use is less than 24 (HH)
If bed_in_use >= 24 Then GoTo Line1
For j = 3 To LrowU
If bed_in_use >= 24 Then GoTo Line1
If arrayX(i) = arrayU(j) Then
If Wait_L > 0 Then
Wait_L = Wait_L - (24 - bed_in_use)
Else
bed_in_use = bed_in_use + 1
End If
End If
Next j
Line1:
For r = 3 To LrowW
If bed_in_use < 24 Then Exit For
If arrayX(i) = arrayW(r) Then
bed_in_use = bed_in_use - 1
Wait_L = Wait_L + 1
End If
Next r
Cells(i, "Y").Value = bed_in_use
Cells(i, "Z").Value = Wait_L
Next i
Easiest way to do this would be to implement a simple class that wraps a Collection. You could wrap an array, but you'd end up either having to copy it every time you dequeued an item or letting dequeued items sit in memory.
In a Class module (I named mine "Queue"):
Option Explicit
Private items As New Collection
Public Property Get Count()
Count = items.Count
End Property
Public Function Enqueue(Item As Variant)
items.Add Item
End Function
Public Function Dequeue() As Variant
If Count > 0 Then
Dequeue = items(1)
items.Remove 1
End If
End Function
Public Function Peek() As Variant
If Count > 0 Then
Peek = items(1)
End If
End Function
Public Sub Clear()
Set items = New Collection
End Sub
Sample usage:
Private Sub Example()
Dim q As New Queue
q.Enqueue "foo"
q.Enqueue "bar"
q.Enqueue "baz"
Debug.Print q.Peek '"foo" should be first in queue
Debug.Print q.Dequeue 'returns "foo".
Debug.Print q.Peek 'now "bar" is first in queue.
Debug.Print q.Count '"foo" was removed, only 2 items left.
End Sub
Would you not follow Comintern's "Class" approach (but I'd go with it!) you can stick to an "array" approach like follows
place the following code in any module (you could place it at the bottom of you code module, but you'd be better placing it in a new module to call, maybe, "QueueArray"...)
Sub Clear(myArray As Variant)
Erase myArray
End Sub
Function Count(myArray As Variant) As Long
If isArrayEmpty(myArray) Then
Count = 0
Else
Count = UBound(myArray) - LBound(myArray) + 1
End If
End Function
Function Peek(myArray As Variant) As Variant
If isArrayEmpty(myArray) Then
MsgBox "array is empty! -> nothing to peek"
Else
Peek = myArray(LBound(myArray))
End If
End Function
Function Dequeue(myArray As Variant) As Variant
If isArrayEmpty(myArray) Then
MsgBox "array is empty! -> nothing to dequeue"
Else
Dequeue = myArray(LBound(myArray))
PackArray myArray
End If
End Function
Sub Enqueue(myArray As Variant, arrayEl As Variant)
Dim i As Long
EnlargeArray myArray
myArray(UBound(myArray)) = arrayEl
End Sub
Sub PackArray(myArray As Variant)
Dim i As Long
If LBound(myArray) < UBound(myArray) Then
For i = LBound(myArray) + 1 To UBound(myArray)
myArray(i - 1) = myArray(i)
Next i
ReDim Preserve myArray(LBound(myArray) To UBound(myArray) - 1)
Else
Clear myArray
End If
End Sub
Sub EnlargeArray(myArray As Variant)
Dim i As Long
If isArrayEmpty(myArray) Then
ReDim myArray(0 To 0)
Else
ReDim Preserve myArray(LBound(myArray) To UBound(myArray) + 1)
End If
End Sub
Public Function isArrayEmpty(parArray As Variant) As Boolean
'http://stackoverflow.com/questions/10559804/vba-checking-for-empty-array
'assylias's solution
'Returns true if:
' - parArray is not an array
' - parArray is a dynamic array that has not been initialised (ReDim)
' - parArray is a dynamic array has been erased (Erase)
If IsArray(parArray) = False Then isArrayEmpty = True
On Error Resume Next
If UBound(parArray) < LBound(parArray) Then
isArrayEmpty = True
Exit Function
Else
isArrayEmpty = False
End If
End Function
then in your main sub you could go like this:
Option Explicit
Sub main()
Dim arrayU As Variant
Dim arrayX As Variant
Dim arrayW As Variant
Dim myVar As Variant
Dim j As Integer, i As Integer, R As Integer
Dim bed_in_use As Integer, Wait_L As Integer
Dim arrayXi As Variant
Const max_bed_in_use As Integer = 24 'best to declare a "magic" value as a constant and use "max_bed_in_use" in lieu of "24" in the rest of the code
'fill "queue" arrays
With ActiveSheet
arrayU = Application.Transpose(.Range(.cells(3, "U"), .cells(.Rows.Count, "U").End(xlUp))) 'fill arrayU
arrayX = Application.Transpose(.Range(.cells(3, "X"), .cells(.Rows.Count, "X").End(xlUp))) 'fill arrayX
arrayW = Application.Transpose(.Range(.cells(3, "W"), .cells(.Rows.Count, "W").End(xlUp))) 'fill arrayW
End With
'some examples of using the "queue-array utilities"
bed_in_use = Count(arrayU) 'get the number of elements in arrayU
Enqueue arrayU, "foo" ' add an element in the arrayU queue, it'll be placed at the queue end
Enqueue arrayU, "bar" ' add another element in the arrayU queue, it'll be placed at the queue end
bed_in_use = Count(arrayU) 'get the update number of elements in arrayU
Dequeue arrayU 'shorten the queue by removing its first element
myVar = Dequeue(arrayU) 'shorten the queue by removing its first element and storing it in "myvar"
bed_in_use = Count(arrayU) 'get the update number of elements in arrayU
MsgBox Peek(arrayU) ' see what's the first element in the queue
End Sub
My end result is to output the names in column A to column B in random order.
I have been researching but cant seem to find what I need.
So far I can kinda of randomise the numbers but its still giving me repeated numbers + the heading (A1).
I need it to skip A1 because this is the heading\title of the column and start at A2.
I assume once that is working correctly I add the randomNumber to a random name to Worksheets("Master Sheet").Cells(randomNumber, "B").Value ...something like that...?
OR if there is a better way of doing this let me know.
Sub Meow()
Dim CountedRows As Integer
Dim x As Integer
Dim i As Integer
Dim PreviousCell As Integer
Dim randomNumber As Integer
i = 1
PreviousCell = 0
CountedRows = Worksheets("Master Sheet").Range("A" & Rows.Count).End(xlUp).Row
If CountedRows < 2 Then
' If its only the heading then quit and display a messagebox
No_People_Error = MsgBox("No People entered or found, in column 'A' of Sheetname 'Master Sheet'", vbInformation, "Pavle Says No!")
Exit Sub
End If
Do Until i = CountedRows
randomNumber = Int((Rnd * (CountedRows - 1)) + 1) + 1
If Not PreviousCell = randomNumber Then
Debug.Print randomNumber
i = i + 1
End If
PreviousCell = randomNumber
Loop
Debug.Print "EOF"
End Sub
Here's a quick hack...
Sub Meow()
'On Error GoTo err_error
Dim CountedRows As Integer
Dim x As Integer
Dim i As Integer
Dim PreviousCell As Integer
Dim randomNumber As Integer
Dim nums() As Integer
PreviousCell = 0
CountedRows = Worksheets("Master Sheet").Range("A" & Rows.Count).End(xlUp).Row
ReDim nums(CountedRows - 1)
If CountedRows < 2 Then
' If its only the heading then quit and display a messagebox
No_People_Error = MsgBox("No People entered or found, in column 'A' of Sheetname 'Master Sheet'", vbInformation, "Pavle Says No!")
Exit Sub
End If
For i = 1 To CountedRows
rand:
randomNumber = randomNumbers(1, CountedRows, nums)
nums(i - 1) = randomNumber
Worksheets("Master Sheet").Range("B" & randomNumber) = Range("A" & i)
Next i
Exit Sub
err_error:
Debug.Print Err.Description
End Sub
Public Function randomNumbers(lb As Integer, ub As Integer, used As Variant) As Integer
Dim r As Integer
r = Int((ub - lb + 1) * Rnd + 1)
For Each j In used
If j = r Then
r = randomNumbers(lb, ub, used)
Else
randomNumbers = r
End If
Next
End Function
I've managed something similar previously using two collections.
Fill one collection with the original data and leave the other collection empty. Then keep randomly picking an index in the first collection, adding the value at that index to the second collection and delete the value from the original collection. Set that to loop until the first collection is empty and the second collection will be full of a randomly sorted set of unique values from your starting list.
***Edit: I've thought about it again and you don't really need the second collection. You can pop a random value from the first collection and write it directly to the worksheet, incrementing the row each time:
Sub Meow()
Dim lst As New Collection
Dim rndLst As New Collection
Dim startRow As Integer
Dim endRow As Integer
Dim No_People_Error As Integer
startRow = 2
endRow = Worksheets("Master Sheet").Cells(startRow, 1).End(xlDown).Row
If Cells(startRow, 1).Value = "" Then
' If its only the heading then quit and display a messagebox
No_People_Error = MsgBox("No People entered or found, in column 'A' of Sheetname 'Master Sheet'", vbInformation, "Pavle Says No!")
Exit Sub
End If
' Fill a collection with the original list
Dim i As Integer
For i = startRow To endRow
lst.Add Cells(i, 1).Value
Next i
' Create a randomized list collection
' Use i as a row counter
Dim rowCounter As Integer
rowCounter = startRow
Dim index As Integer
Do While lst.Count > 0
'Find a random index in the original collection
index = Int((lst.Count - 1 + 1) * Rnd + 1)
'Place the value in the worksheet
Cells(rowCounter, 2).Value = lst(index)
'Remove the value from the list
lst.Remove (index)
'Increment row counter
rowCounter = rowCounter + 1
Loop
End Sub
P.S. I hope there's an excellent story behind naming your sub Meow() :P
I have a range I am looping through in VBA:
For Lrow = Firstrow To Lastrow Step 1
With .Cells(Lrow, "E")
If Not IsError(.Value) Then
End If
End With
Next Lrow
Within that if statement I need to load an array with each value only once
MB-NMB-ILA
MB-NMB-ILA
MB-NMB-STP
MB-NMB-STP
MB-NMB-WAS
MB-NMB-WAS
MB-NMB-WAS
So for the array I only want MB-NMB-ILA, MB-NMB-STP, and MB-NMB-WAS
Can anyone help me out, my brain isn't working right on a Monday! Thanks
You could use filter to test if something exists in the array.
Dim arr As Variant: arr = Array("test1", "test2", "test3")
If UBound(Filter(arr, "blah")) > -1 Then
Debug.Print "it is in the array"
Else
Debug.Print "it's not in the array"
End If
You could also use a collection and write a sub to add only unique items to the collection
Dim col As New Collection
Sub addIfUnique(sAdd As String)
Dim bAdd As Boolean: bAdd = True
If col.Count > 0 Then
Dim iCol As Integer
For iCol = 1 To col.Count
If LCase(col(iCol)) = LCase(sAdd) Then
bAdd = False
Exit For
End If
Next iCol
End If
If bAdd Then col.Add sAdd
End Sub
Private Sub Command1_Click()
Dim a As Integer
Dim b As Integer
For a = 1 To 10
addIfUnique "item " & a
For b = 1 To 10
addIfUnique "item " & b
Next b
Next a
For a = 1 To col.Count
Debug.Print col(a)
Next a
End Sub
Suppose I have the following in cell A1 to A5 and want an array of unique values i.e. {a,b,c,d}
A
1 "a"
2 "b"
3 "c"
4 "c"
5 "d"
The follow two pieces of code will help achieve this:
CreateUniqueArray - get val from each cell and add to array if not already in array
IsInArray - utility function to check if value in array by performing simple loop
I have to say that this is the brute force way and would welcome any improvements...
Sub Test()
Dim firstRow As Integer, lastRow As Integer, cnt As Integer, iCell As Integer
Dim myArray()
cnt = 0
firstRow = 1
lastRow = 10
For iCell = firstRow To lastRow
If Not IsInArray(myArray, Cells(iCell, 1)) Then
ReDim Preserve myArray(cnt)
myArray(cnt) = Cells(iCell, 1)
cnt = cnt + 1
End If
Next iCell
End Sub
Function IsInArray(myArray As Variant, val As String) As Boolean
Dim i As Integer, found As Boolean
found = False
If Not Len(Join(myArray)) > 0 Then
found = False
Else
For i = 0 To UBound(myArray)
If myArray(i) = val Then
found = True
End If
Next i
End If
IsInArray = found
End Function