Randomise numbers without repeating the number - vba
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
Related
Using multiple listbox in noncontiguous ranges
I am working with a schedule, that I have imported and formatted into my workbook. I am wanting this to populate Phase in the upper listbox and then when a phase is selected the sub-task associated with those phases are displayed in the bottom listbox. I want to use an array but I seem to be having problems when the columns are not next to each other or there are "gaps" with the blank cells. My first attempt using assigning the Array to the currentregion worked but brought all columns and fields in. Listbox1 should contain (ID, PHASE NAME, DURATION, START DATE, FINISH DATE) List box 2 should when a Phase is selected contain the subtasks if any from the column to the right, listed before the next next Phase name. (ID, SUB-TASK NAME, DURATION, START DATE, FINISH DATE) (See picture) I have code but its more me trouble-shooting than an actual semi working script. Dim shT As Worksheet Dim schnumrng1 As Range Dim schnumrng2 As Range Dim schnumrng3 As Range Dim schnumrng4 As Range Dim schnumrng5 As Range Dim schpersonrng As Range Dim schphaserng As Range Dim schlistrng As Range Dim maxschnum Dim schstatus Dim schperson Dim schlistnum Dim Ar() As String Dim i As Long Dim j As Long Dim rng As Range Dim cl As Range Dim lc 'allowevents = True ''Set Screen parameters 'Application.ScreenUpdating = False 'Application.EnableEvents = False ' Worksheets("Schedule").Visible = True ThisWorkbook.Worksheets("Schedule").Activate ' Set shT = Worksheets("Schedule") maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row Set schnumrng = Range("B5", "B" & maxschnum) 'Set Ranges for the list box Set schnumrng1 = Range("A5", "A" & maxschnum) Set schnumrng2 = Range("B5", "B" & maxschnum) Set schnumrng3 = Range("D5", "D" & maxschnum) Set schnumrng4 = Range("E5", "E" & maxschnum) Set schnumrng5 = Range("F5", "F" & maxschnum) 'This is static and not moving to the next line in my for statement / switched to named ranges and errors Set rng = schnumrng1, schnumrng2, schnumrng3, schnumrng4, schnumrng5 'Set rng = Range("A5,B5,D5,E5,F5") i = 1 j = 1 For Each lc In schnumrng If lc <> vbNullString Then For Each cl In rng ReDim Preserve Ar(1, 1 To i) Ar(j, i) = cl.Value i = i + 1 Next cl Else End If j = j + 1 Next lc With ScheduleForm.SchMainTasklt .ColumnCount = i - 1 .ColumnWidths = "50;150;50;50;50" .List = Ar End With My problem then is two fold, trying to use the dynamic ranges or another tool Index? collection? to populate the 1st list box. 2. How to deal with blanks and noncontiguous columns when data is not separated for organization purposes.
I don't know if I figured out your intentions well. First, only the data in column b, not empty cells, is extracted from listbox1. Second, when listbox1 is selected, data related to listbox2 is collected through the selected listbox value. Module Code Place this code in the module. This is because global variables must be used. Public vDB As Variant Public Dic As Object 'Dictionary Sub test() Dim shT As Worksheet Dim maxschnum As Long Dim Ar() As String Dim i As Long Dim j As Long Dim vC() As Variant Dim cnt As Integer, n As Integer Dim c As Integer Dim s As String, s2 As String Worksheets("Schedule").Visible = True ThisWorkbook.Worksheets("Schedule").Activate ' Set Dic = CreateObject("Scripting.Dictionary") 'New Scripting.Dictionary Set shT = Worksheets("Schedule") maxschnum = shT.Cells(shT.Rows.Count, "A").End(xlUp).Row With shT vDB = .Range("a5", .Range("f" & maxschnum)) End With 'vC is data colum A,B,D,E,F vC = Array(1, 2, 4, 5, 6) s2 = vDB(2, 2) For i = 2 To UBound(vDB, 1) s = vDB(i, 2) 'column B If s = "" Then n = n + 1 Else If Dic.Exists(s) Then Else If i > 2 Then Dic(s2) = Dic(s2) & "," & n End If Dic.Add s, i s2 = s cnt = cnt + 1 ReDim Preserve Ar(1 To 5, 1 To cnt) For c = 0 To UBound(vC) Ar(c + 1, cnt) = vDB(i, vC(c)) Next c End If n = 0 End If Next i Dic(s2) = Dic(s2) & "," & n ' Records information about the data in a dictionary. ' Dic is "phase neme" is Key, Item is "2,4" ' example for KICkOFF ' dic key is "KICKOFF", Item is "5,4" ' 5 is KICOFF's row number in array vDB ' 4 is the number of blank cells related to kickoff. With ScheduleForm.SchMainTasklt .ColumnCount = 5 .ColumnWidths = "50;150;50;60;60" .BoundColumn = 2 '.List = Ar .Column = Ar 'In the state that the array has been converted to row column, you can use listbox.column. End With End Sub Form Code Private Sub UserForm_Initialize() Call test End Sub Private Sub SchMainTasklt_Click() Dim s As String, sItem As String Dim arr As Variant, vC As Variant Dim vR() As Variant Dim st As Long, ed As Long Dim iLast As Long, iFirst As Long Dim i As Long, n As Integer Dim j As Integer vC = Array(1, 3, 4, 5, 6) 'data colums A,C,D,E,F s = SchMainTasklt.Value 'MsgBox s sItem = Dic(s) arr = Split(sItem, ",") st = Val(arr(0)) ed = Val(arr(1)) iFirst = st + 1 iLast = st + ed If ed = 0 Then MsgBox "no data!!" Exit Sub End If For i = iFirst To iLast n = n + 1 ReDim Preserve vR(1 To 5, 1 To n) For j = 0 To UBound(vC) vR(j + 1, n) = vDB(i, vC(j)) Next j Next i With ListBox2 .ColumnCount = 5 .ColumnWidths = "50;150;50;60;60" .BoundColumn = 2 .Column = vR End With End Sub Result Image When you click the "KICKOFF" , Show kickoff related data in listbox2.
excel , extract the time Break from one cell in excel sheet?
I have an Excel sheet like below and I need only the three "Break" times even if it meant to delete every thing except those three Breaks in every cell. Function GetBreaksTime(txt As String) Dim i As Long Dim arr As Variant arr = Split(txt, "Break") If UBound(arr) > 0 Then ReDim startTimes(1 To UBound(arr)) As String For i = 1 To UBound(arr) startTimes(i) = WorksheetFunction.Trim(Replace(Split(arr(i), "-")(0), vbLf, "")) Next GetBreaksTime = startTimes End If End Function This what I got until now but it wont work on every cell and it takes wrong values. So any idea how to do this?
If you split the cell value by vbLf the break time will always follow a line containing "Break". The following should work: Sub TestGetBreakTimes() Dim CellValue As String CellValue = Worksheets("Sheet1").Range("A1").Value Dim BreakTimes As Variant BreakTimes = GetBreakTimes(CellValue) Debug.Print Join(BreakTimes, vbLf) 'the join is just to output the array at once. 'to output in different cells loop through the array Dim i As Long For i = 0 To UBound(BreakTimes) Cells(3 + i, "A") = BreakTimes(i) Next i 'or for a even faster output use Range("A3").Resize(UBound(BreakTimes) + 1).Value = WorksheetFunction.Transpose(BreakTimes) End Sub Function GetBreakTimes(InputData As String) As Variant Dim BreakTimes() As Variant ReDim BreakTimes(0) Dim SplitArr As Variant SplitArr = Split(InputData, vbLf) 'split by line break If UBound(SplitArr) > 0 Then Dim i As Long For i = 0 To UBound(SplitArr) If SplitArr(i) = "Break" Then 'if line contains break then next line is the time of the break If BreakTimes(0) <> vbNullString Then ReDim Preserve BreakTimes(UBound(BreakTimes) + 1) BreakTimes(UBound(BreakTimes)) = SplitArr(i - 1) 'collect break time End If Next i GetBreakTimes = BreakTimes End If End Function To analyze a complete range you must loop through your row 2 Sub GetAllBreakTimes() Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("Sheet1") Dim LastCol As Long LastCol = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column Dim BreakTimes As Variant Dim iCol As Long For iCol = 1 To LastCol BreakTimes = GetBreakTimes(ws.Cells(2, iCol).Value) ws.Cells(3, iCol).Resize(UBound(BreakTimes) + 1).Value = WorksheetFunction.Transpose(BreakTimes) Next iCol End Sub
VBA to extract names from a list at random isn't working
I want to randomly extract 280 names from a list (dynamic range) of thousands of authors, then concatenate them into 1 string with each name separated by OR. So far I'm stuck at the first part. When I run the following code, nothing happens. Can anyone explain why? Thanks. Sub Authors() Dim InputRange As Range Dim AuthorCount As Long Dim AuthorRange As Excel.Range Set InputRange = Range("A:A") AuthorCount = Application.WorksheetFunction.CountA(InputRange) - 1 Set AuthorRange = ThisWorkbook.Worksheets("Sheet").Range("A2:A" & AuthorCount) Const nItemsToPick As Long = 280 Dim Authorlist As Variant Dim i As Long ReDim Authorlist(1 To nItemsToPick) For i = 1 To nItemsToPick Authorlist(i) = AuthorRange.Cells(Int(AuthorCount * Rnd + 1), 1) Next i End Sub
Using the below code Sub PickSample(intSampleSize As Integer, intPicks As Integer) Dim arr() As String Dim intCounter As Integer ReDim arr(intPicks) For intCounter = 0 To UBound(arr) arr(intCounter) = CStr(Int((intSampleSize - (i - 1)) * Rnd + 1) + (i - 1)) Next intCounter Debug.Print Join(arr(), ",") End Sub I ran this on the following, PickSample(10,5) and got the following, showing the duplicate possibilities, this will become less as the difference between picks and samples increases. 9,9,6,10,10,2 5,3,6,7,2,3 10,4,5,8,0,6 9,8,4,10,9,0 0,8,8,7,0,4 7,5,6,3,3,8 If your selection is 280, but the data set is only 300, dupes still arise PickSample 300,280 228,**92**,248,216,269,66,**107**,166,**107**,61,174,189,41,18,190,252,192,127,56,149,292,231,114,145,164,202,11,194,270,102,35,128,232,**107**,124,225,131,216,152,52,83,26,294,85,186,**92**,256,96,239,52,90,21,148,136,179,9,95,40,98,228,188,290,249,166,182,57,271,95,180,179,230,215,206,228,77,165,153,170,84,125,105,292,156,175,139,9,113,41,196,46,59,112,28,185,211,132,126,101,210,64,13,266,13,138,222,227,247,63,141,261,249,123,139,105,75,242,163,162,188,26,214,77,17,82,289,98,194,109,111,98,64,63,127,185,72,206,177,181,23,13,46,74,120,175,86,251,270,158,116,0,75,49,194,295,93,72,264,39,171,182,183,208,255,29,118,247,80,204,119,251,130,251,65,220,270,65,295,290,262,157,195,137,47,193,184,257,110,15,152,16,112,135,89,291,3,195,184,160,8,215,94,295,87,109,96,106,70,178,211,80,173,173,298,280,75,243,231,122,189,148,150,40,291,53,177,205,32,195,222,234,129,24,150,172,17,124,35,43,94,298,181,82,125,141,19,137,131,284,82,52,152,103,154,119,78,20,192,109,164,265,127,178,114,17,32,43,43,228,79,41,12,208,254,155,240,296,157,20,188,99,83 4,50,49,153,122,31,83,193,255,149,56,269,112,97,232,65,134,71,264,183,112,117,259,176,280,155,99,261,77,78,53,104,0,223,253,83,211,121,244,223,131,23,123,102,213,93,240,45,178,287,73,282,34,296,190,180,271,173,73,258,22,132,228,73,113,119,158,81,174,63,23,269,33,196,271,69,285,254,132,148,231,251,115,58,98,124,45,186,29,61,208,151,55,298,141,1,128,86,226,268,247,53,32,3,45,113,56,294,262,175,219,43,77,8,249,235,238,100,135,167,241,169,61,62,109,172,103,158,128,172,15,164,62,289,280,298,252,123,242,297,77,52,209,5,102,208,33,33,87,120,168,93,88,243,93,113,120,253,123,218,198,122,286,194,155,67,175,225,137,272,85,200,267,84,110,4,88,296,229,174,182,80,152,238,258,28,163,125,22,135,210,150,122,284,296,178,160,185,26,55,85,5,45,126,165,168,235,12,122,17,93,181,155,179,99,273,231,173,129,220,49,17,73,228,286,103,205,238,10,239,145,62,181,273,284,196,4,199,290,2,287,22,88,175,243,12,16,169,94,124,153,220,135,97,22,123,172,229,174,196,243,125,239,217,208,219,57,232,21,74,286,246,66,55,71,278,77,77,215,200,232 209,294,73,160,32,300,203,4,173,30,31,240,85,13,89,114,90,285,294,120,83,48,49,194,123,124,214,98,190,62,55,175,24,137,272,78,236,114,87,276,190,188,128,29,168,209,275,251,6,163,275,129,204,151,154,139,106,121,81,16,73,294,18,117,109,147,46,142,77,189,163,47,282,197,152,117,32,235,138,226,179,250,5,63,22,31,99,38,0,161,197,163,249,24,57,204,136,107,45,212,279,159,26,228,120,139,148,62,99,28,177,51,279,29,133,82,262,225,82,202,77,27,9,97,237,89,70,144,76,102,13,145,62,260,177,227,279,99,163,24,190,123,289,34,277,186,104,44,144,66,299,39,8,103,164,277,162,122,255,248,202,217,300,102,149,124,209,53,127,163,245,162,128,153,68,186,147,204,266,111,91,88,45,159,67,175,109,263,143,57,205,224,184,235,48,243,60,287,19,18,238,114,139,35,34,52,14,215,160,168,65,140,224,226,120,271,224,26,191,214,4,129,120,82,296,241,209,125,221,83,107,130,284,36,194,104,31,55,23,130,288,163,148,292,65,114,119,84,151,41,155,290,167,273,197,132,208,19,227,210,149,46,67,98,236,15,155,227,241,97,292,242,203,272,263,125,37,287,239,209,120 Using a dictionary to handle the dupes, using this code Sub PickSample(intSampleSize As Integer, intPicks As Integer) Dim dicPicked As New Scripting.Dictionary Dim arr() As String Dim intCounter As Integer Dim intPicked As Integer ReDim arr(intPicks) For intCounter = 0 To UBound(arr) RetryPick: intPicked = CStr(Int((intSampleSize - (i - 1)) * Rnd + 1) + (i - 1)) If dicPicked.Exists(CStr(intPicked)) Then GoTo RetryPick Else dicPicked.Add CStr(intPicked), 1 arr(intCounter) = intPicked End If Next intCounter Debug.Print Join(arr(), ",") dicPicked.RemoveAll Set dicPicked = Nothing End Sub Gives results, hopefully dupe free PickSample 300,280 203,125,69,114,26,208,39,219,36,174,220,113,24,74,104,282,128,112,223,205,200,147,44,143,152,162,157,300,70,54,108,177,13,276,153,91,7,168,89,145,127,12,16,257,187,229,61,213,117,214,254,171,59,242,23,51,224,52,185,165,193,189,21,296,63,173,160,280,190,232,235,141,256,56,87,98,32,5,267,195,77,120,197,82,288,68,57,136,132,182,122,15,47,48,261,96,110,258,49,105,155,86,186,97,225,80,264,140,11,46,199,230,275,19,34,83,222,66,116,294,298,259,292,271,272,84,115,101,124,43,183,71,289,291,25,188,55,158,150,216,243,92,58,0,290,148,255,149,250,167,27,233,228,265,9,299,65,283,62,88,207,240,109,179,161,178,268,278,175,139,237,234,169,297,269,281,184,262,270,164,202,279,253,295,196,212,8,274,159,75,172,163,130,38,154,73,99,247,249,263,273,67,40,20,221,138,14,33,218,286,227,251,94,166,209,156,211,37,137,90,131,111,107,2,215,85,146,100,293,204,231,285,79,53,126,60,239,260,248,78,4,217,29,64,121,226,201,210,45,206,134,17,1,192,246,3,35,191,236,93,28,41,244,287,129,277,142,118,6,81,18,135,181,241,180,103,50,252,31,95,30 44,278,132,10,232,56,146,193,284,276,236,155,79,117,102,61,119,200,229,131,138,133,235,173,204,34,7,98,3,202,167,143,130,30,126,206,13,262,221,166,174,298,111,116,39,288,263,76,47,170,89,268,154,253,52,91,217,148,12,22,83,33,77,264,85,214,55,127,279,251,101,86,230,35,172,59,198,62,286,296,220,29,191,242,271,5,54,84,297,158,38,270,231,107,95,110,57,129,9,273,53,269,68,4,234,228,211,207,70,153,151,194,179,128,169,63,142,109,145,58,186,24,245,60,87,0,17,246,225,222,218,184,258,26,161,226,247,31,144,178,223,122,88,124,137,210,293,94,99,213,190,281,80,72,104,40,6,123,290,259,254,45,78,66,227,289,261,141,65,135,8,274,69,257,203,168,196,42,248,67,73,125,37,11,287,181,92,291,238,108,212,1,118,28,216,244,164,249,240,150,46,74,277,36,189,188,255,224,195,260,15,175,267,280,49,180,27,165,50,113,243,201,237,149,205,156,199,292,136,48,71,75,285,41,81,239,209,185,266,160,176,152,171,163,100,2,32,183,16,97,19,294,187,20,282,272,157,182,121,140,106,112,265,295,51,21,256,64,241,114,162,90,252,115,25,82,103,23,299,120,197 57,241,105,1,247,289,284,72,89,68,101,225,295,242,290,5,291,217,267,87,62,80,24,106,103,38,285,197,286,300,151,222,219,254,201,113,195,245,243,15,179,98,145,192,74,118,142,109,70,58,11,4,154,277,129,115,250,202,293,163,181,168,288,268,281,112,79,49,60,175,236,23,266,186,59,167,190,187,41,228,174,157,48,231,165,253,227,171,66,176,135,238,120,258,19,110,194,164,131,296,91,206,159,255,8,189,124,148,114,13,75,121,95,272,119,214,50,117,279,213,205,133,96,196,137,173,246,218,233,77,27,264,141,184,193,263,102,83,244,210,78,127,36,63,188,42,0,152,198,271,169,298,207,111,3,158,182,282,30,226,199,17,273,297,191,166,46,144,252,55,25,26,200,86,162,237,211,299,212,287,161,12,40,45,69,216,54,125,71,47,132,93,22,20,76,126,51,262,107,229,234,257,2,39,278,235,84,37,280,208,153,251,67,136,104,28,221,149,248,276,170,140,14,269,180,16,108,34,94,43,92,52,204,65,134,85,183,7,146,143,97,270,64,259,139,160,260,223,32,81,177,33,178,185,90,292,9,232,209,265,10,88,283,147,123,99,261,240,6,138,274,122,61,203,249,155,256,44,294,116,35
this function picks nItemsToPick random elements up from arr array and returns them into an array: Function PickNRandomElementsFromArray(arr As Variant, nItemsToPick As Long) As Variant Dim arrSize As Long Dim i As Long, iPick As Long Dim temp As String arrSize = UBound(arr) '<--| count the values as the array size If nItemsToPick > arrSize Then nItemsToPick = arrSize '<--| the items to be picked cannot exceed array size For i = 1 To nItemsToPick iPick = Int((arrSize - (i - 1)) * Rnd + 1) + (i - 1) '<--| pick a random number between 'i' and 'arrSize' ' swap array elements in slots 'i' and 'iPick' temp = arr(iPick) arr(iPick) = arr(i) arr(i) = temp Next i ReDim Preserve arr(1 To nItemsToPick) '<--| resize the array to first picked items PickNRandomElementsFromArray = arr '<--| return the array End Function which you can exploit as follows: Option Explicit Sub Authors() Dim Authors As Variant, AuthorsList As Variant With ThisWorkbook.Worksheets("Sheet") '<--| reference your relevant worksheet Authors = Application.Transpose(.Range("A2", .Cells(.rows.count, 1).End(xlUp)).Value) '<--| fill 'Authors' array with its column "A" values from row 2 down to its last not empty one AuthorsList = PickNRandomElementsFromArray(Authors, 280) '<--| fill 'AuthorsList' array with a selection of 280 random elements of 'Authors' .Range("B1").Value = Join(AuthorsList, " OR ") '<--| fill cell "B1" with a string build by concatenating 'AuthorsList' values delimited with " OR " End With End Sub that can be quite contracted (and made as much less readable) to: Sub Authors() With ThisWorkbook.Worksheets("Sheet") '<--| reference your relevant worksheet .Range("B1").Value = Join(PickNRandomElementsFromArray(Application.Transpose(.Range("A2", .Cells(.rows.count, 1).End(xlUp)).Value), 280), " OR ") End With End Sub
From your comments, you seem to want to concatenate the array of strings, then put it back into excel. This, put just before the End Sub, will put it into cell B1 for example: ThisWorkbook.Worksheets("Sheet1").Range("B1").Value = Join(Authorlist, "OR")
VBA Removing ListBox Duplicates
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
Loading an array with only unique values
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