Excel VBA function to print an array to the workbook - vba
I've written a macro that takes a 2 dimensional array, and "prints" it to equivalent cells in an excel workbook.
Is there a more elegant way to do this?
Sub PrintArray(Data, SheetName, StartRow, StartCol)
Dim Row As Integer
Dim Col As Integer
Row = StartRow
For i = LBound(Data, 1) To UBound(Data, 1)
Col = StartCol
For j = LBound(Data, 2) To UBound(Data, 2)
Sheets(SheetName).Cells(Row, Col).Value = Data(i, j)
Col = Col + 1
Next j
Row = Row + 1
Next i
End Sub
Sub Test()
Dim MyArray(1 To 3, 1 To 3)
MyArray(1, 1) = 24
MyArray(1, 2) = 21
MyArray(1, 3) = 253674
MyArray(2, 1) = "3/11/1999"
MyArray(2, 2) = 6.777777777
MyArray(2, 3) = "Test"
MyArray(3, 1) = 1345
MyArray(3, 2) = 42456
MyArray(3, 3) = 60
PrintArray MyArray, "Sheet1", 1, 1
End Sub
On the same theme as other answers, keeping it simple
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End Sub
Sub Test()
Dim MyArray() As Variant
ReDim MyArray(1 To 3, 1 To 3) ' make it flexible
' Fill array
' ...
PrintArray MyArray, ActiveWorkbook.Worksheets("Sheet1").[A1]
End Sub
Create a variant array (easiest by reading equivalent range in to a variant variable).
Then fill the array, and assign the array directly to the range.
Dim myArray As Variant
myArray = Range("blahblah")
Range("bingbing") = myArray
The variant array will end up as a 2-D matrix.
A more elegant way is to assign the whole array at once:
Sub PrintArray(Data, SheetName, StartRow, StartCol)
Dim Rng As Range
With Sheets(SheetName)
Set Rng = .Range(.Cells(StartRow, StartCol), _
.Cells(UBound(Data, 1) - LBound(Data, 1) + StartRow, _
UBound(Data, 2) - LBound(Data, 2) + StartCol))
End With
Rng.Value2 = Data
End Sub
But watch out: it only works up to a size of about 8,000 cells. Then Excel throws a strange error. The maximum size isn't fixed and differs very much from Excel installation to Excel installation.
As others have suggested, you can directly write a 2-dimensional array into a Range on sheet, however if your array is single-dimensional then you have two options:
Convert your 1D array into a 2D array first, then print it on sheet (as a Range).
Convert your 1D array into a string and print it in a single cell (as a String).
Here is an example depicting both options:
Sub PrintArrayIn1Cell(myArr As Variant, cell As Range)
cell = Join(myArr, ",")
End Sub
Sub PrintArrayAsRange(myArr As Variant, cell As Range)
cell.Resize(UBound(myArr, 1), UBound(myArr, 2)) = myArr
End Sub
Sub TestPrintArrayIntoSheet() '2dArrayToSheet
Dim arr As Variant
arr = Split("a b c", " ")
'Printing in ONE-CELL: To print all array-elements as a single string separated by comma (a,b,c):
PrintArrayIn1Cell arr, [A1]
'Printing in SEPARATE-CELLS: To print array-elements in separate cells:
Dim arr2D As Variant
arr2D = Application.WorksheetFunction.Transpose(arr) 'convert a 1D array into 2D array
PrintArrayAsRange arr2D, Range("B1:B3")
End Sub
Note: Transpose will render column-by-column output, to get row-by-row output transpose it again - hope that makes sense.
HTH
My tested version
Sub PrintArray(RowPrint, ColPrint, ArrayName, WorkSheetName)
Sheets(WorkSheetName).Range(Cells(RowPrint, ColPrint), _
Cells(RowPrint + UBound(ArrayName, 2) - 1, _
ColPrint + UBound(ArrayName, 1) - 1)) = _
WorksheetFunction.Transpose(ArrayName)
End Sub
You can define a Range, the size of your array and use it's value property:
Sub PrintArray(Data, SheetName As String, intStartRow As Integer, intStartCol As Integer)
Dim oWorksheet As Worksheet
Dim rngCopyTo As Range
Set oWorksheet = ActiveWorkbook.Worksheets(SheetName)
' size of array
Dim intEndRow As Integer
Dim intEndCol As Integer
intEndRow = UBound(Data, 1)
intEndCol = UBound(Data, 2)
Set rngCopyTo = oWorksheet.Range(oWorksheet.Cells(intStartRow, intStartCol), oWorksheet.Cells(intEndRow, intEndCol))
rngCopyTo.Value = Data
End Sub
Related
Sorting by column using character in middle of each cell, without helper column
Is it possible to sort a range by a column, but sort using a single character in the middle of the string in each cell? So column looks like this: red(7) blue(4) orange(9) green(2) etc.. I want to sort it using the number within the brackets. My current code sorts the columns alphabetically: With sheetSUMMARY .Range(.Cells(summaryFirstRow, summaryReForenameCol)), _ .Cells(summaryLastRow, summaryReColourCol))). _ Sort _ key1:=.Range(.Cells(summaryFirstRow, summaryReColourCol)), _ .Cells(summaryLastRow, summaryReColourCol))), _ order1:=xlAscending, _ Header:=xlNo End With So it looks like this: blue(4) green(2) orange(9) red(7) Without making a helper column in excel (which extracts the numbers), is it possible to sort it like this purely programatically? (I haven't really got space for a helper column at this stage) green(2) blue(4) red(7) orange(9)
You can use a Dictionary to store your values and their corresponding numbers and then there are a number of sorting methods. I opted to use an ArrayList to do the sorting rather than writing a bespoke sorting function. Public Sub SortByNumber() Dim arrayList As Object, inputDictionary As Object, outputDictionary As Object 'late binding so you can drop the code in easily Dim rng As Range, r As Range Dim num As Double Dim v As Variant Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1:A4") Set arrayList = CreateObject("System.Collections.ArrayList") Set inputDictionary = CreateObject("Scripting.Dictionary") Set outputDictionary = CreateObject("Scripting.Dictionary") 'put current values into dictionary and arraylist For Each r In rng num = CLng(Mid(r.Value, InStr(r.Value, "(") + 1, Len(r.Value) - InStr(r.Value, "(") - 1)) Do While inputDictionary.exists(num) 'avoid errors with duplicates numbers (see comments) num = num + 0.00000001 Loop inputDictionary.Add Item:=r.Value, Key:=num arrayList.Add num Next r arrayList.Sort 'use sorted arraylist to determine order of items in output dictionary For Each v In arrayList.toarray outputDictionary.Add Item:=v, Key:=inputDictionary.Item(v) Next v 'output values to the next column -- just remove the offset to overwrite original values rng.Offset(0, 1).Value = WorksheetFunction.Transpose(outputDictionary.keys()) End Sub The result looks like this:
You can do something interesting, if you really do not want to add a helper column. Pretty much the following: let's say your inputRange is Range("A1:A4") declare a variant virtualRange, which would be a bit of a tricky - it would take the values of the inputRange and the next column: virtualRange = Union(inputRange, inputRange.Offset(0, 1)).Value then loop through your inputRange and assign the cell value to the second dimension of the virtualRange. It should pretty much look like this in the local window: Now the funny part - pass the virtualRange to the SortDataBySecondValue and it will return the virtualRange sorted. Here is a really important point - if you pass the virtualRange with parenthesis, like this SortDataBySecondValue (virtualRange) nothing useful would happen - the parenthesis overrule the ByRef argument in SortDataBySecondValue() and the virtualRange would remain untact. At the end you have your virtualRange sorted and you have to pass its values correctly to the inputRange. This is achievable with a simple loop: For Each myCell In inputRange Dim cnt As Long cnt = cnt + 1 myCell = virtualRange(cnt, 1) Next myCell Now the inputRange is sorted as expected: The whole code is here: Option Explicit Public Sub TestMe() Dim inputRange As Range Dim myCell As Range Dim virtualRange As Variant Set inputRange = Range("A1:A4") virtualRange = Union(inputRange, inputRange.Offset(0, 1)).Value For Each myCell In inputRange.Columns(1).Cells virtualRange(myCell.Row, 2) = locateNumber(myCell) Next myCell SortDataBySecondValue virtualRange For Each myCell In inputRange Dim cnt As Long cnt = cnt + 1 myCell = virtualRange(cnt, 1) Next myCell End Sub Public Function locateNumber(ByVal s As String) As Long Dim startIndex As Long Dim endIndex As Long startIndex = InStr(1, s, "(") + 1 endIndex = InStr(1, s, ")") locateNumber = Mid(s, startIndex, endIndex - startIndex) End Function Sub SortDataBySecondValue(ByRef Data As Variant) Dim i As Long Dim j As Long Dim temp As Variant Dim sortBy As Long: sortBy = 2 ReDim temp(UBound(Data) - 1, sortBy) For i = LBound(Data) To UBound(Data) For j = i To UBound(Data) If Data(i, sortBy) > Data(j, sortBy) Then temp(i, 1) = Data(i, 1) temp(i, sortBy) = Data(i, sortBy) Data(i, 1) = Data(j, 1) Data(i, sortBy) = Data(j, sortBy) Data(j, 1) = temp(i, 1) Data(j, sortBy) = temp(i, sortBy) End If Next j Next i End Sub
Try this: Sub OrderByColumn() Dim i As Long, tempColumn As Long, colorColumn As Long, color As String 'get table to variable Dim tableToOrder As Range 'here ypou have to specify your own range!! Set tableToOrder = Range("A1:C5") colorColumn = tableToOrder.Column tempColumn = colorColumn + tableToOrder.Columns.Count 'insert new column at the end of the table and populate with extracted numbers Columns(tempColumn).Insert For i = tableToOrder.Row To (tableToOrder.Rows.Count + tableToOrder.Row - 1) color = Cells(i, colorColumn).Value Cells(i, tempColumn).Value = Mid(color, InStr(1, color, "(") + 1, InStr(1, color, ")") - InStr(1, color, "(") - 1) Next i = i - 1 'now i points to last row in range 'order whole table accordingly to temporary column Range(Cells(tableToOrder.Row, tableToOrder.Column), Cells(i, tempColumn)).Sort Key1:=Range(Cells(tableToOrder.Row, tempColumn), Cells(i, tempColumn)) 'delete column Columns(tempColumn).Delete End Sub
VBA - Convert multiple delimited columns into multiple row
I was wondering if someone can help me with the following, In VBA in Excel, I have the following table : Column 1|Column2|Column3|Column4|Column5|Column6 ---------|---------|---------|---------|---------|--------- 1.2.3.4|Apple%Car|Canada%USA|Tomatoes|Hotel|Montreal%Paris%New-York 1.3.4.6|Cat%Uniform%Dog|France|Ananas|Motel|Amsterdam%San-Diego And I would like to convert this in Excel using VBA into the following table : Column 1|Column 2|Column 3|Column 4|Column 5|Column 6 :---------:|:---------:|:---------:|:---------:|:---------:|:---------: 1.2.3.4|Apple|Canada|Tomatoes|Hotel|Montreal 1.2.3.4|Apple|Canada|Tomatoes|Hotel|Paris 1.2.3.4|Apple|Canada|Tomatoes|Hotel|New-York 1.2.3.4|Apple|USA|Tomatoes|Hotel|Montreal 1.2.3.4|Apple|USA|Tomatoes|Hotel|Paris 1.2.3.4|Apple|USA|Tomatoes|Hotel|New-York 1.2.3.4|Car|Canada|Tomatoes|Hotel|Montreal 1.2.3.4|Car|Canada|Tomatoes|Hotel|Paris 1.2.3.4|Car|Canada|Tomatoes|Hotel|New-York 1.2.3.4|Car|USA|Tomatoes|Hotel|Montreal 1.2.3.4|Car|USA|Tomatoes|Hotel|Paris 1.2.3.4|Car|USA|Tomatoes|Hotel|New-York 1.3.4.6|Cat|France|Ananas|Motel|Amsterdam 1.3.4.6|Cat|France|Ananas|Motel|San-Diego 1.3.4.6|Uniform|France|Ananas|Motel|Amsterdam 1.3.4.6|Uniform|France|Ananas|Motel|San-Diego 1.3.4.6|Dog|France|Ananas|Motel|Amsterdam 1.3.4.6|Dog|France|Ananas|Motel|San-Diego Does anyone have an idea how to do this ? Thank you !
To get my brain going I bit. This does more or less what you want (However there is room for improvement as it currently can produce duplicate rows which it then removes at the end. I've missed something but as you haven't tried anything I haven't put any more effort in figuring out where this is happening exactly). You'll also have to change the Ranges for where your inputs and outputs come from in the ConvertToTable sub. This uses a recursive function (i.e. one that calls itself) to populate your output Option Explicit Public Sub ConvertToTable() Dim data As Variant, tmp() As Variant Dim arr() As Variant Dim i As Long Dim c As Range With Sheet2 data = Range(.Cells(1, 1), .Cells(2, 6)).Value2 End With For i = LBound(data, 1) To UBound(data, 1) tmp = Application.Index(data, i, 0) arr = PopulateResults(tmp, "%", arr) Next i With Sheet4 With .Range(.Cells(1, 1), .Cells(UBound(arr, 2), UBound(arr, 1))) .Value2 = Application.Transpose(arr) .RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlNo End With End With End Sub Public Function PopulateResults(tmp As Variant, delimiter As String, Results() As Variant) As Variant() Dim i As Long, j As Long Dim DelCount As Long, MaxDel As Long Dim tmp2 As Variant On Error Resume Next i = UBound(Results, 2) + 1 If i = 0 Then i = 1 On Error GoTo 0 ReDim Preserve Results(1 To UBound(tmp), 1 To i) For j = 1 To UBound(tmp) Results(j, i) = tmp(j) If InStr(1, tmp(j), delimiter, vbTextCompare) Then DelCount = 0 Results(j, i) = Split(tmp(j), delimiter)(DelCount) Do DelCount = DelCount + 1 tmp2 = tmp tmp2(j) = Split(tmp(j), delimiter)(DelCount) Results = PopulateResults(tmp2, delimiter, Results) Loop Until DelCount = Len(tmp(j)) - Len(Replace(tmp(j), delimiter, vbNullString)) End If Next j PopulateResults = Results End Function
Thank you very much, It is much appreciated. Sorry for the delay, I didn't get any e-mail notification for the response. I played with the source code and I have the following, it works for all the column that contain short value.. : 'Transform the data Dim data As Variant, tmp() As Variant Dim arr() As String Dim i As Long Dim c As Range With Aggregation_Source data = Range(Cells(1, 1), Cells(2, 8)).Value2 End With For i = LBound(data, 1) To UBound(data, 1) tmp = Application.Index(data, i, 0) arr = PopulateResults(tmp, "%", arr) Next i With Aggregation_Source With Range(Cells(1, 1), Cells(UBound(arr, 2), UBound(arr, 1))) .Value2 = Application.Transpose(arr) .RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, 7), Header:=xlNo End With End With End Sub Public Function PopulateResults(tmp As Variant, delimiter As String, Results() As String) As String() Dim i As Long, j As Long Dim DelCount As Long, MaxDel As Long Dim tmp2 As Variant On Error Resume Next i = UBound(Results, 2) + 1 If i = 0 Then i = 1 On Error GoTo 0 ReDim Preserve Results(1 To UBound(tmp), 1 To i) For j = 1 To UBound(tmp) Results(j, i) = tmp(j) If InStr(1, tmp(j), delimiter, vbTextCompare) Then DelCount = 0 Results(j, i) = Split(tmp(j), delimiter)(DelCount) Do DelCount = DelCount + 1 tmp2 = tmp tmp2(j) = Split(tmp(j), delimiter)(DelCount) Results = PopulateResults(tmp2, delimiter, Results) Loop Until DelCount = Len(tmp(j)) - Len(Replace(tmp(j), delimiter, vbNullString)) End If Next j PopulateResults = Results End Function Now, I think that the code crash because I have one column that contains two long text separated by % more than a 1000 characters, I will try to change the type for arr() to see if it works but I think I am missing something in the code .
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")
Why am I having issues assigning an array to a Range
Why is the the first item of my array getting assigned to all cells in the range? Private Sub sample() Dim arr() As Double, rng As Range, i As Double ReDim arr(1 To 100) For i = 1 To 100 arr(i) = i * Rnd Next i Set rng = Range("A1:A100") rng.Value = arr End Sub Based on the Locals window, my array has populated as expected: But when the array is assigned to the the range, it assigns the first value to all cells:
In order to assign the array to a range, the array needs to be declared as a 2 dimensional array. Even if the 2nd dimension only has 1 element: ReDim arr(1 To 100, 1 To 1) The working example looks like this: Private Sub sample() Dim arr() As Double, rng As Range, i As Double ReDim arr(1 To 100, 1 To 1) For i = 1 To 100 arr(i, 1) = i * Rnd Next i Set rng = Range("A1:A100") rng.Value = arr End Sub
The array is a horizontal 1 dimensional array and it needs to be transposed to a vertical 1 dimensional array: Private Sub sample() Dim arr() As Double, rng As Range, i As Double ReDim arr(1 To 100) For i = 1 To 100 arr(i) = i * Rnd Next i Set rng = Range("A1:A100") rng.Value = Application.Transpose(arr) End Sub The only caveat of this is if there is more than roughly 64,500 elements then the transposing needs to be done manually, with a loop.
Try this: Sub sample() Dim arr() As Double, rng As Range, i As Double ReDim arr(1 To 100) Set rng = Range("A1:A100") For i = 1 To 100 arr(i) = i * Rnd rng.Cells(i, 1).Value = arr(i) Next i End Sub
VBA script to count string, insert rows, copy row, split cell
The department that provides me a spreadsheet to be used in my database now includes multiple text in a cell. In order to link to that data I have to turn it into multiple rows. Example: LC123/LC463/LC9846 needs to have the entire row copied with just one "LC" string in each row- cell1 cell2 LC123 cell1 cell2 LC463 cell1 cell2 LC9846 I tried these two subroutines but obviously it failed Sub InSert_Row() Dim j As Long j = InputBox(=SUM(LEN(ActiveCell)-LEN(SUBSTITUTE(ActiveCell,"LC",""))-1) ActiveCell.EntireRow.Copy ActiveCell.Offset(j).EntireRow.Insert Shift:=xlDown End Sub Sub SplitAndTranspose() Dim N() As String N = Split(ActiveCell, Chr(10)) ActiveCell.Resize(UBound(N) + 1) = WorksheetFunction.Transpose(N) End Sub The 2nd subroutine will split and copy but it doesn't insert rows, it writes over the rows below it.
'In memory' method Inserting rows as necessary would be perhaps the most simple to understand, but the performance of making thousands of seperate row inserts would not be good. This would be fine for a one off (perhaps you only need a one-off) and should only take a minute or two to run but I thought what the heck and so wrote an approach that splits the data in memory using a collection and arrays. It will run in the order of seconds. I have commented what it is doing. Sub ProcessData() Dim c As Collection Dim arr, recordVector Dim i As Long, j As Long Dim rng As Range Dim part, parts 'replace with your code to assign the right range etc Set rng = ActiveSheet.UsedRange j = 3 'replace with right column index, or work it out using Range.Find etc arr = rng.Value 'load the data 'Process the data adding additional rows etc Set c = New Collection For i = 1 To UBound(arr, 1) parts = Split(arr(i, j), "/") 'split the data based on "/" For Each part In parts 'loop through each "LC" thing recordVector = getVector(arr, i) 'get the row data recordVector(j) = part 'replace the "LC" thing c.Add recordVector 'add it to our results collection Next part Next i 'Prepare to dump the data back to the worksheet rng.Clear With rng.Parent .Range( _ rng.Cells(1, 1), _ rng.Cells(1, 1).Offset(c.Count - 1, UBound(arr, 2) - 1)) _ .Value = getCollectionOfVectorsToArray(c) End With End Sub 'Helper method to return a vector representing our row data Private Function getVector(dataArray, dataRecordIndex As Long) Dim j As Long, tmpArr ReDim tmpArr(LBound(dataArray, 2) To UBound(dataArray, 2)) For j = LBound(tmpArr) To UBound(tmpArr) tmpArr(j) = dataArray(dataRecordIndex, j) Next j getVector = tmpArr End Function 'Helper method to return an array from a collection of vectors Function getCollectionOfVectorsToArray(c As Collection) Dim i As Long, j As Long, arr ReDim arr(1 To c.Count, LBound(c(1), 1) To UBound(c(1), 1)) For i = 1 To c.Count For j = LBound(arr, 2) To UBound(arr, 2) arr(i, j) = c(i)(j) Next j Next i getCollectionOfVectorsToArray = arr End Function Edit: Alternative "Range Insert" method. It will be slower (although I made the number of discrete insert and copy operations be based on original row count, not some recursive sweep so it is not too bad) but is simpler to understand and so to perhaps tweak if needed. It should run in the order of a couple of minutes. Sub ProcessData_RangeMethod() Dim rng As Range Dim colIndex As Long Dim parts Dim currRowIndex As Long 'replace with your code to assign the right range etc Set rng = ActiveSheet.UsedRange colIndex = 3 'replace with right column index, or work it out using Range.Find etc Application.ScreenUpdating = False Application.Calculation = xlCalculationManual currRowIndex = 1 Do Until currRowIndex > rng.Rows.Count parts = Split(rng.Cells(currRowIndex, colIndex), "/") If UBound(parts) > 0 Then rng.Range(rng.Cells(currRowIndex + 1, 1), rng.Cells(currRowIndex + UBound(parts), rng.Columns.Count)).Insert xlShiftDown rng.Rows(currRowIndex).Copy rng.Range(rng.Cells(currRowIndex + 1, 1), rng.Cells(currRowIndex + UBound(parts), rng.Columns.Count)) rng.Range(rng.Cells(currRowIndex, colIndex), rng.Cells(currRowIndex + UBound(parts), colIndex)).Value = Application.Transpose(parts) End If currRowIndex = currRowIndex + 1 + UBound(parts) Loop Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub