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