Appending new positions to a form listbox - vba

I have a UserForm in Excel with a ListBox, which must show the result of a computation. The problem is when I try to fill the Listbox using a recursive loop the information which was there earlier is replaced with new data. How can I append new information to the content in the ListBox and not lose earlier information?
My current code:
Dim Form As HistoryFRM, ARR(), i, ArrHistory()
.....
Set Form = New HistoryFRM
With Form
.Show vbModeless
.LBHistory.ColumnCount = 6
For i = 0 To UBound(ARR)
ArrHistory = SQL_Editor("SELECT * FROM [Table] WHERE [ID]='" & ARR(i) & "';")
.LBHistory.Column = ArrHistory
Next i
End With

If I understand you correctly, you want to fill six columns with the array you're getting from the data base. Both the List and Countproperties replace the content of their lists when an array is assigned. The AddItem method allows you to append new items to the list, but in one dimension, only.
In order to append a new array of items, I believe you first need to read the current list into an array, append the new items to that array, then write the entirety back to the ListBox. Here's an example:
Dim arr()
Dim lb As ListBox
Dim numCols As Long
Dim rowCount As Long, colCount As Long
Dim numNewRecs As Long, newRecCount As Long
Set lb = Me.ListBox1
'You need to know how many new records are coming in
'Substitute this determination here:
numNewRecs = 2
numCols = lb.ColumnCount - 1
'Dimension the array for the current list plus the new records
ReDim arr(lb.ListCount - 1 + numNewRecs, numCols)
'Get the current list
For rowCount = 0 To lb.ListCount - 1
For colCount = 0 To numCols
arr(rowCount, colCount) = lb.List(rowCount, colCount)
Next
Next
'Append the new records
For newRecCount = rowCount To rowCount + numNewRecs - 1
For colCount = 0 To numCols
arr(newRecCount, colCount) = "New data" & CStr(newRecCount)
Next
Next
'Populate the ListBox
lb.List = arr()

Try this
Option Explicit
Dim Form As HistoryFRM, ARR() As Variant, ArrHistory() As Variant
Dim i As Long, j As Long
....
Set Form = New HistoryFRM
With Form
.Show vbModeless
With .LBHistory
.ColumnCount = 6
For i = 0 To UBound(ARR)
ArrHistory = SQL_Editor("SELECT * FROM [Table] WHERE [ID]='" & ARR(i) & "';")
For j = LBound(ArrHistory) To UBound(ArrHistory)
.AddItem ArrHistory(j)
Next
Next
End With
End With

Related

Nested For Loop dealing with one collection in VBA

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!

Fastest way to update large data in Excel Table

I have a large table in Excel that has to be updated from a JSON source.
The data is fetched and available to me in the form of a dictionary after parsing the JSON.
I am iterating over all the fields in the data and updating relevant columns in a table.
Public Function GetFields(ByVal sApiEndpoint As String, ByVal sSheetName As String, ByVal sTableName As String)
.........
'Parse the Json Response and Update Table
Dim dicParsed As Dictionary
With ActiveWorkbook.Sheets(sSheetName).ListObjects(sTableName)
Dim iCount As Integer
iCount = 1
Set dicParsed = JsonConverter.ParseJson(sRestResponse)
For Each Item In dicParsed("data")
iCount = iCount + 1
Next Item
If .ListRows.Count >= 1 Then
.DataBodyRange.Delete
End If
Set Rng = .Range.Resize(iCount, .HeaderRowRange.Columns.Count)
.Resize Rng
Dim iRow As Integer
iRow = 0
For Each Item In dicParsed("data")
On Error Resume Next
.DataBodyRange.Cells(iRow, .ListColumns("name").Index) = Item("name")
.DataBodyRange.Cells(iRow, .ListColumns("id").Index) = Item("id")
.DataBodyRange.Cells(iRow, .ListColumns("type").Index) = Item("schema")("type")
iRow = iRow + 1
Next Item
End With
.........
End Function
It takes around 5 minutes to update a table of 500 rows with 15 columns with the calculations and updates turned off.
Is there any faster way to update the data in this scenario?
You can push the updates to an array and then bulk update the table.
Dim an array of any type without giving a size. Use Variant if you have columns of different type like numbers and strings.
ReDim the array when you know final dimensions.
Update the array with the data.
Set the tables databody equal to the array.
I was able to reduce update time from 5 minutes to less than 5 seconds with the below code.
Public Function GetFields(ByVal sApiEndpoint As String, ByVal sSheetName As String, ByVal sTableName As String)
.........
'Parse the Json Response and Update Table
Dim dicParsed As Dictionary
With ActiveWorkbook.Sheets(sSheetName).ListObjects(sTableName)
Dim iCount As Integer
Dim arrDataBuffer() As Variant
iCount = 1
Set dicParsed = JsonConverter.ParseJson(sRestResponse)
For Each Item In dicParsed("data")
iCount = iCount + 1
Next Item
If .ListRows.Count >= 1 Then
.DataBodyRange.Delete
End If
Set Rng = .Range.Resize(iCount, .HeaderRowRange.Columns.Count)
.Resize Rng
ReDim arrDataBuffer(iCount, .HeaderRowRange.Columns.Count)
Dim iRow As Integer
iRow = 0
For Each Item In dicParsed("data")
On Error Resume Next
arrDataBuffer(iRow, .ListColumns("name").Index - 1) = Item("name")
arrDataBuffer(iRow, .ListColumns("id").Index - 1) = Item("id")
arrDataBuffer(iRow, .ListColumns("type").Index - 1) = Item("schema")("type")
iRow = iRow + 1
Next Item
.DataBodyRange = arrDataBuffer
End With
.........
End Function

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")

excel vba add a set number of items to a collection

I have the following set of code:
For loopCounter = 2 To endRow
Dim item As Variant
Dim lineArray()
Dim myString As String
myString = Cells(loopCounter, 3).Value
ReDim lineArray(1 To endColumn)
If Not (Left(myString, 1) = "P" Or Left(myString, 1) = "I" Or myString = "RESW" Or myString = "REPC") Then
For x = 1 To endColumn
lineArray(x) = dataArray(loopCounter, x)
Next x
itemCollection.Add lineArray
End If
Next loopCounter
For the purpose of keeping this question short and to the point, I have a bunch of excel worksheets that contains hundreds of rows of data. To make a long story short, the code above add items from the worksheet to the collection, but it's adding every row (minus the conditions I set - if statement). However, I only want to add a fix amount of items to the collection, 15. I can't seem to figure it out and haven't found any help online.
My question for help is, does anyone know how I can make it that once 15 items are added to the collection it will exit out of the loop and finish the rest of the subroutine?
I purposely didn't add the whole code because it's quite lengthy and not necessary.
Thank you.
Sure thing, just check on the collection.Count > 14 then exit for
For loopCounter = 2 To endRow
Dim item As Variant
Dim lineArray()
Dim myString As String
myString = Cells(loopCounter, 3).Value
ReDim lineArray(1 To endColumn)
If Not (Left(myString, 1) = "P" Or Left(myString, 1) = "I" Or myString = "RESW" Or myString = "REPC") Then
For x = 1 To endColumn
lineArray(x) = dataArray(loopCounter, x)
Next x
itemCollection.Add lineArray
if itemCollection.Count = 15 then exit for
End If
Next loopCounter
if it would have been an array, then use if UBOUND(array) = 14 then exit for

Randomize a list in Microsoft Word

I am a teacher and I have been making a number of multiple choice tests for students using Microsoft Word. Is there a way for me to automatically shuffle the questions so that I can have multiple versions of the test without needing to copy and paste the questions around my test?
Looking online I found a one solution posted by Steve Yandl in which he used macro after putting each question on a separate row in a table. I am trying to get his macro to work but it has and error. I know next to nothing about coding, so I am stuck. Here is his code:
Sub ShuffleQuestions()
Dim Tmax As Integer
Dim strCell As String
Dim strQ As Variant
Dim strText As String
Dim I As Integer
Dim Z As Integer
Dim intQsLeft As Integer
Dim rndQ As Integer
Dim Q As Integer
Dim vArray As Variant
Dim strNew As String
Set objDict = CreateObject("Scripting.Dictionary")
Tmax = ThisDocument.Tables(1).Rows.Count
For I = 1 To Tmax
strCell = ThisDocument.Tables(1).Cell(I, 1).Range.Text
strQ = Left(strCell, Len(strCell) - 1)
objDict.Add strQ, strQ
Next I
ReDim arrQs(I - 1)
intQsLeft = I - 2
Z = 0
Do While intQsLeft = 0
Randomize
rndQ = Int((intQsLeft + 1) * Rnd)
intQsLeft = intQsLeft - 1
vArray = objDict.Items
strText = vArray(rndQ)
arrQs(Z) = strText
Z = Z + 1
objDict.Remove strText
Loop
For Q = 1 To Tmax
strNew = arrQs(Q - 1)
strNew = Left(strNew, Len(strNew) - 1)
ThisDocument.Tables(1).Cell(Q, 1).Range.Text = strNew
Next Q
End Sub
The error message I get says "run time error 5941 the requested member of the collection does not exist"
When I choose the 'Debug' button it brings me to the line of code in the macro that says "Tmax = ThisDocument.Tables(1).Rows.Count"
Ultimately I just want to reorder the questions, but I would be delighted if there was also a way to reorder my multiple choice options for each question.
Does your document have a table?
Where did you put the sub (ShuffleQuestions)?
Are you sure you added it to your document and didn't add it to the document template (probably normal).
If, after running the code, reaching the error and clicking debug, you highlight ThisDocument.Tables, right clicking on the highlighted text and select "Add Watch" from the popup menu you should be able to see if ThisDocument.Tables contains any data.
I suspect it will be empty. It will be empty if:
You haven't added a table to your document
You have added the sub to normal.dot in which case ThisDocument will refer to the normal template and not the document you are actually editing.
So, the solution is either:
Make sure your sub is in the document you are editing (and not the document template)
That you have a table in your document.
There are also some programming errors in the sub ShuffleQuestions (e.g. Do While intQsLeft = 0 should be something like Do While intQsLeft > 0).
The following code works (and is a lot simpler):
Sub ShuffleQuestions()
Dim numberOfRows As Integer
Dim currentRowText As String
Dim I As Integer
Dim doc As Document
Set doc = ActiveDocument
'Find the number of rows in the first table of the document
numberOfRows = doc.Tables(1).Rows.Count
'Initialise (seed) the random number generator
Randomize
'For each row in the table
For I = 1 To numberOfRows
'Find a new row number (any row in the table)
newRow = Int(numberOfRows * Rnd + 1)
'Unless we're not moving to a new row
If newRow <> I Then
'Get the current row text
currentRowText = CleanUp(doc.Tables(1).Cell(I, 1).Range.Text)
'Overwrite the current row text with the new row text
doc.Tables(1).Cell(I, 1).Range.Text = CleanUp(doc.Tables(1).Cell(newRow, 1).Range.Text)
'Put the current row text into the new row
doc.Tables(1).Cell(newRow, 1).Range.Text = currentRowText
End If
Next I
End Sub
Function CleanUp(value As String) As String
'Remove control characters from the end of the string (the cell text has a 'BELL' character and CR at the end)
While (Len(value) > 0 And Asc(Right(value, 1)) < 32)
value = Left(value, Len(value) - 1)
Wend
CleanUp = value
End Function
For those who wants to randomize all the paragraphs in a document.
To make it work, put your cursor at the end of your document with no selections.
Sub ran_para()
n = ActiveDocument.Paragraphs.Count
ReDim a(1 To 2, 1 To n)
Randomize
For i = 1 To n
a(1, i) = Rnd
a(2, i) = i
Next
For i = 1 To n - 1
For j = i + 1 To n
If a(1, j) > a(1, i) Then
t = a(2, i)
a(2, i) = a(2, j)
a(2, j) = t
End If
Next
Next
'Documents.Add
For i = 1 To n
Set p = ActiveDocument.Paragraphs.Add
p.Range.Text = ActiveDocument.Paragraphs(a(2, i)).Range.Text
Next
End Sub