I'm attempting to grab strings from a specific range of one worksheet and output the array onto another sheets range. Unfortunately the resulting code gives me no output of any sort.
Thank you for the help in advance.
Dim strFunds As String
Dim varItemName As Variant
Dim strItemName() As String
Dim iRow As Long
Dim rngMyRange As Range
Sub DataGrab()
ActiveWorkbook.Sheets("Returns").Activate
Set rngMyRange = Range("A5:A100")
varItemName = rngMyRange
ReDim strItemName(LBound(varItemName, 1) To UBound(varItemName, 1))
ActiveWorkbook.Sheets("Data").Activate
Range("A3:A" & UBound(strItemName) + 1) = WorksheetFunction.Transpose(strItemName)
End Sub
Sub Main()
Dim rngArr
rngArr = Sheets("Returns").Range("A5:B100").Value
Sheets("Data").Range("A3").Resize(UBound(rngArr) + 1, 2) = rngArr
End Sub
EDIT: Oops didn't see me how's answer above. This answer is pretty much the same thing.
Try this.
First, change varItemName to an array:
Dim varItemName() As Variant
Then:
Sub DataGrab()
ActiveWorkbook.Sheets("Returns").Activate
Set rngMyRange = Range("A5:A100")
varItemName = rngMyRange.Value
'ReDim strItemName(LBound(varItemName, 1) To UBound(varItemName, 1))
ActiveWorkbook.Sheets("Data").Activate
Range("A3").Resize(1, UBound(varItemName) + 1) = WorksheetFunction.Transpose(varItemName)
End Sub
That is assuming you want to convert your columnar data into a single row. If not, do this on the last line instead:
Range("A3").Resize(UBound(varItemName) + 1, 1) = varItemName
You are not assigning any values to strItemName. Here's a version that just keeps everything in varItemName.
ActiveWorkbook.Sheets("Returns").Activate
Set rngMyRange = Range("A5:A100")
varItemName = rngMyRange.Value
ActiveWorkbook.Sheets("Data").Activate
Range(Cells(3, 1), Cells(3, UBound(varItemName))) = WorksheetFunction.Transpose(varItemName)
UPDATE: If you don't need to save varItemName, you can use this shorter version:
Set rngMyRange = Range("A5:A100")
ActiveWorkbook.Sheets("Data").Activate
Range(Cells(3, 1), Cells(3, 100)) = WorksheetFunction.Transpose(rngMyRange)
Related
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
I am working on a list and doing all the calculations on VBA however when i want to write my list to the predefined range i get nothing. The following is a an example of the code i'm using. I am not posting the actual code because it's long however this example has the same problem.
Option Explicit
Sub readArray()
Dim CoGrade() As Variant
Dim LastRow As Integer
Dim NPSeQuedan() As Variant
Dim SeQuedanRng As Range
'erases information from arrays if there was any
Erase CoGrade
Erase NPSeQuedan
'-------------------------------------------------------------------------
'find the last row on the data i want to read
LastRow = Range("b10000").End(xlUp).Row
'the relevant data starts on row 34
ArrayRows = LastRow - 34 + 1
'redifines the variables with the total numbers of stocks in the portfolio
ReDim CoGrade(ArrayRows, 1)
ReDim NPSeQuedan(ArrayRows, 1)
'reads each relevant number into its proper variable
CoGrade = Range(Cells(34, 2), Cells(LastRow, 2))
'' test
Set SeQuedanRng = Range(Cells(34, 13), Cells(34 + ArrayRows - 1,
13))
For a = 1 To ArrayRows
NPSeQuedan(a, 1) = CoGrade(a, 1)
Next
SeQuedanRng.Value = NPSeQuedan
'''
end sub
Here is another solution (though #SJR 's idea of using 1-dimensional arrays is good). I added various points about your original code in the comments to the code:
Sub readArray()
Dim CoGrade As Variant 'Don't bother with ()
Dim LastRow As Long 'Integer risks overflow
Dim A As Long, ArrayRows As Long 'you use these -- so declare it
Dim NPSeQuedan As Variant 'etc.
Dim SeQuedanRng As Range
'erases information from arrays if there was any
'Erase CoGrade -- VBA is garbage collected and these have just been declared, so 100% pointless
'Erase NPSeQuedan
'-------------------------------------------------------------------------
'find the last row on the data i want to read
LastRow = Cells(Rows.Count, "B").End(xlUp).Row 'why hard-wire in 10000?
'the relevant data starts on row 34
ArrayRows = LastRow - 34 + 1
'redifines the variables with the total numbers of stocks in the portfolio
'ReDim CoGrade(ArrayRows, 1) -- pointless
ReDim NPSeQuedan(1 To ArrayRows, 1 To 1) 'this is important for what you are doing
'reads each relevant number into its proper variable
CoGrade = Range(Cells(34, 2), Cells(LastRow, 2)).Value
'' test
Set SeQuedanRng = Range(Cells(34, 13), Cells(34 + ArrayRows - 1, 13))
For A = 1 To ArrayRows
NPSeQuedan(A, 1) = CoGrade(A, 1)
Next
SeQuedanRng.Value = NPSeQuedan 'works now!
End Sub
You can do it like this, which incorporates several of the comments made by John Coleman.
Sub readArray()
Dim CoGrade As Variant
Dim LastRow As Long, ArrayRows as Long, a as Long
Dim NPSeQuedan() As Variant
Dim SeQuedanRng As Range
'find the last row on the data i want to read
LastRow = Range("b10000").End(xlUp).Row
'the relevant data starts on row 34
ArrayRows = LastRow - 34 + 1
'redifines the variables with the total numbers of stocks in the portfolio
ReDim NPSeQuedan(1 To ArrayRows)
'reads each relevant number into its proper variable
CoGrade = Range(Cells(34, 2), Cells(LastRow, 2))
Set SeQuedanRng = Range(Cells(34, 13), Cells(34 + ArrayRows - 1, 13))
For a = 1 To ArrayRows
NPSeQuedan(a) = CoGrade(a, 1)
Next
SeQuedanRng.Value = Application.Transpose(NPSeQuedan)
End Sub
i need to put in a variable a range of values, i.e. the variable
tsPeriod(1) = (3, 4, 5)
tsPeriod(3) = (1, 2, 3).
I don't know what kind of variable to declare and how to do it. I've tried to do something like this:
Dim tsPeriod() as long
ReDim tsPeriod(nSub) as long
for i = 1 to nSub
tsPeriod(i) = (tsStart(i), tsEnd(i))
next
But it doesnt work that way and im kinda lost how to put that "range" into that variable. (if the first value is 3 and the second is 6 i want the variable to retrieve (3, 4, 5, 6))
Below is part of the code:
Dim wb As Workbook
Set wb = ThisWorkbook
Dim subjects As Worksheet
Set subjects = wb.Sheets("Subject")
Dim nSub As Integer, nRooms As Integer
nSub= subjects.Cells(Rows.Count, 1).End(xlUp).value
Dim tsStart() As Long
ReDim tsStart(nSub) As Long
For i = 1 To nSub
tsStart(i) = subjects.Cells(i + 1, 3).value
Next
Dim tsBusy() As Long
ReDim tsBusy(numDis) As Long
For i = 1 To nSub
tsBusy(i) = subjects.Cells(i + 1, 4).value
Next
Dim tsEnd() As Long
ReDim tsEnd(nSub) As Long
For i = 1 To nSub
tsEnd(i) = tsStart(i) + tsBusy(i) - 1
Next
'Here's where im having trouble
Dim tsPeriod() As Long
ReDim tsPeriod(nSub) As Long
For i = 1 To nSub
tsPeriod(i) = (tsStart(i), TsEnd(i))
Next
There is no built-in "range" method in VBA: you need to dimension an array of the required size and fill it using a loop. You can create a function to do this:
Function RRange(startNum, endNum)
Dim rv() as long, i
Redim rv(1 to (endnum-startnum)+1)
for i = startNum to endNum
rv((i-startNum)+1) = i
next i
RRange = rv
End Function
Then:
For i = 1 To numDis
tsPeriod(i) = RRange(tsStart(i), TsEnd(i))
Next
You can use the combination of Application.Transpose, Evaluate and the worksheets-ROW function to get there.
For the
tsPeriod(i) = (tsStart(i), TsEnd(i))
simply use
tsPeriod(i) = Application.Transpose(Evaluate("=ROW(" & tsStart(i) & ":" & tsEnd(i) & ")"))
To get an array from the first to the last value.
To just get a comma-separated string, put this in a Join like this
tsPeriod(i) = Join(Application.Transpose(Evaluate("=ROW(" & tsStart(i) & ":" & tsEnd(i) & ")")), ",")
Join also is good for testing if everything is fine, because you can use Debug.Print.
Here is the Situation: In my Excel sheet I had a column with entries in the form 1-name. I wanted to remove the numbers, taking into account that the number can also be double digit. This by itself was not a Problem and I got it working, just the Performance is so bad. As it is now my program needs about half a second per cell entry.
My question: How can I improve the performance?
Here is the code:
Sub remove_numbers()
Dim YDim As Long
Dim i As Integer, l As Integer
Dim val As String
Dim s As String
YDim = Cells(Rows.Count, 5).End(xlUp).Row
For i = 8 To YDim
val = Cells(i, 5)
l = Len(val)
s = Mid(val, 2, 1)
If s = "-" Then
val = Right(val, l - 2)
Else
val = Right(val, l - 3)
End If
Cells(i, 5).Value = val
Next i
End Sub
Instead of using 3 different functions: Len(), Mid(), Right() you could use a Split() function which would have been much more efficient in this case.
Try the below code
Sub remove_numbers()
Application.ScreenUpdating = False
Dim i As Long
For i = 8 To Cells(Rows.Count, 5).End(xlUp).Row
Cells(i, 5) = Split(Cells(i, 5), "-")(1)
Next i
Application.ScreenUpdating = True
End Sub
My suggestion:
Sub remove_numbers()
Dim i As Integer, values() As Variant
values = Range(Cells(8, 5), Cells(Rows.Count, 5).End(xlUp).Row).Value
For i = LBound(values) To UBound(values)
values(i, 1) = Mid(values(i, 1), IIf(Mid(values(i, 1), 2, 1) = "-", 2, 3))
Next
Range(Cells(8, 5), Cells(Rows.Count, 5).End(xlUp).Row).Value = values
End Sub
Optimizations:
Perform all calculations in memory and them update entire range: this is a HUGE performance gain;
Condensed multiple commands into a single command;
Replaced Right(x, Len(x)-n) with Mid(x, n).
EDIT:
As suggested by #Mehow, you may also gain some performance using
values(i, 1) = Split(values(i, 1), "-", 2)(1)
instead of values(i, 1) = Mid(values(i, 1), IIf(Mid(values(i, 1), 2, 1) = "-", 2, 3))
You should manipulate the whole range values as an array and work directly with it in memory.
Something like :
Dim valuesOfRangeToModify() As Variant
Set valuesOfRangeToModify = Range(Cells(8, 5), Cells(Rows.Count, 5).End(xlUp)).Value
For Each cell In valuesOfRangeToModify
cell = ... // remove numbers
Next
Range(Cells(8, 5), Cells(Rows.Count, 5).End(xlUp)).Value = valuesOfRangeToModify
My VB is quite old so it probably has syntax errors but you get the idea.
This should give a huge boost.
For reference, here is an article full of interesting advices, see point #4 for more explanation of the solution given above :
http://www.soa.org/news-and-publications/newsletters/compact/2012/january/com-2012-iss42-roper.aspx
Also do not operate one cell at a time. Create a range of cells and transfer them into an array for processing. In the end the array can be used to replace the cells.
To tweak the answer from #mehow
Sub remove_numbers()
Dim i As Long, N as Long, r as Range
Set r = Range("B3") ' Whatever is the first cell in the column
N = Range(r, r.End(xlDown)).Rows.Count 'Count the rows in the column
Set r = r.Resize(N,1) ' Expand the range with all the cells
Dim values() as Variant
values = r.Value ' Collect all the values from the sheet
For i=1 to N
values(i,1) = Split( values(i,1), "-")(1)
Next i
r.Value = values 'Replace values to the sheet
End Sub
To make it more general you can add an argument to the procedure to pass a reference to the first cell in the column, like Sub remove_numbers(ByRef r as Range). There is no need to de-activate the screen as there is only one write operation in the end and you want the screen to update after that.
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