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