Code worked fine with fixed dim array but when I have added line to Redim to make Results array dynamic the code will not allow results to be added to array coming up with "Type Mismatch" error. I am sure a simple fix, have played around but can I see it..
GP (Gross Profit) Range of values picked up form single column range GPRange and Price Change its from single row PriceRange).
Option Explicit
Sub CalcVolTable()
'Macro to produce table that shows relationship between price and volume change
Dim PriceChangeAr As Variant, GPAr As Variant
Dim GPList, GPNum, PriceIndex, PriceChNum As Integer
Dim GP As Double
With ThisWorkbook
' Read all PriceChanges into a 1-dimensional array
PriceChangeAr = (.Worksheets("Results").Range("PriceRange").Value2)
' Read all GP range into a 1-dimensional array
GPAr = Application.Transpose(.Worksheets("Results").Range("GPRange").Value)
'Clear Previous Results
Range("VolTable").ClearContents
Range("Output").Select
'Set up Results Array
'Dim VolResultsAr(1 To 8, 1 To 7) As Variant - this worked before I tried to make array dynamic
Dim VolResultsAr As Variant
PriceChNum = UBound(PriceChangeAr, 2)
GPNum = UBound(GPAr)
ReDim VolResults(1 To GPNum, 1 To PriceChNum) As Variant
For GPList = LBound(GPAr) To UBound(GPAr)
GP = GPAr(GPList)
'Set Cost per Unit value to get right GP in calc
Range("CostPerUnit").Value = 100 * (1 - GP)
' Now loop through each pricechange
For PriceIndex = LBound(PriceChangeAr, 2) To UBound(PriceChangeAr, 2)
'Reset Price and Vol adjt cell to zero
Range("ChPrice") = 0
Range("Chvol") = 0
'enter new Price Cahnge value
Range("ChPrice").Value = PriceChangeAr(1, PriceIndex)
'Use goal seek to calc vol chage req'd to bring GP back to same preset value
Range("GP").GoalSeek Goal:=GP, ChangingCell:=Range("ChVol")
'Writes result to cells in table in spreadsheet
Range("Output").Offset(GPList - 1, PriceIndex - 1).Value = Range("ChVol").Value
'CODE FALLING DOWN HERE - TRYING TO WRITE EACH RESULT INTO ARRAY
VolResultsAr(GPList, PriceIndex) = Range("ChVol").Value
Next PriceIndex
Next GPList
Range("Output2").Resize(UBound(VolResultsAr, 1), UBound(VolResultsAr, 2)) = VolResultsAr
Range("Output").Select
End With
MsgBox "done!"
End Sub
Assuming the arrays need to match you need to ReDim VolResultsAr
ReDim VolResults(1 To GPNum, 1 To PriceChNum) As Variant
ReDim VolResultsAr(1 To GPNum, 1 To PriceChNum) As Variant
And for lines like:
Dim GPList, GPNum, PriceIndex, PriceChNum As Integer .
Only PriceChNum is Integer, the others are variant. Is that what you intended? And Integer should be replaced with Long to avoid potential overflow
Related
I am trying to learn to use variant data type but facing issues.
Public Function z_score(sections As Range, marks As Range) As Variant
Dim n As Integer
Dim score() As Variant 'marks range has a few empty cells and error cells as well
'hence using variant data type
n = UBound(sections.Value)
ReDim score(1 To n, 1 To 2)
score = marks.Value 'assigning marks range values to first column of score
For i = 1 To n 'adding second column with integer index for calling later
score(i, 2) = i
Next i
z_score = score
End Function
I am getting value error instead of nx2 matrix as output.
Can you please help how to resolve the error.
Any help is much appreciated, thanks..
There are a few areas that could cause this code to fail, I'm afraid:
If the passed in range is only 1 cell, the assignment to an array will throw an error.
VBA doesn't have a method for copying or cloning arrays, so your code score = marks.Value isn't doing what your comments are saying,
The sections parameter doesn't appear to be doing anything. You are sizing the array against it, but then iterating the marks array to assign values.
I'm not sure what you want to do with the function, but if it is a UDF called from a worksheet, it would need to be a formula array.
You could adjust your code as follows to have something a little more robust:
Public Function z_score(marks As Range) As Variant
Dim scoreArray() As Variant, marksArray() As Variant
Dim i As Long
marksArray = RangeValueToArray(marks)
ReDim scoreArray(1 To UBound(marksArray, 1), 1 To 2)
For i = 1 To UBound(marksArray, 1)
scoreArray(i, 1) = i
scoreArray(i, 2) = marksArray(i, 1)
Next
z_score = scoreArray
End Function
Private Function RangeValueToArray(rng As Range) As Variant
Dim v() As Variant
If rng.Cells.Count = 1 Then
ReDim v(1 To 1, 1 To 1)
v(1, 1) = rng.Value2
RangeValueToArray = v
Exit Function
End If
v = rng.Value2
RangeValueToArray = v
End Function
I think I figured out the problem. Assigning values of range to array works but makes the assigned array two dimensional array but with only 1 column if given range has only one column or row! So moving the redim with preserve to after assignment line worked for my purpose.
But if one wants to assign values to a column other than first in a 2D array (albeit with 1 column), only solution I am aware of at this point is to do iteration the way Ambie suggested.
Public Function z_score(sections As Range, marks As Range) As Variant
Dim score() As Variant 'marks range has a few empty cells and error cells as well
'hence using variant data type
Dim n As Integer
n = UBound(sections.Value)
score = marks.Value 'assigning marks range values to first column of score
ReDim Preserve score(1 To n, 1 To 2)
For i = 1 To n 'adding second column with integer index for calling later
score(i, 2) = i
Next i
z_score = score
End Function
I’ve been experimenting with arrays to find a faster alternative to VLOOKUP(), which can take a long time to execute with very large data sets.
I searched SO and many other sites, grabbing snippets of code.
The data:
A1:A5 the list of values to lookup (1,2,3,4,5)
C1:C5 the range to ‘find’ the values (2,4,6,8,10)
D1:D5 the range of values to ‘return’ (a,b,c,d,e)
B1:B5 is where I’d like to paste the ‘looked-up’ values.
The code works up to a point, in that it does return correct values for the ‘looked-up’ value’s position in C1:C5 – and the correct values in the adjacent cells in D1:D5.
When I try to load the returned values to Arr4 (the array to be pasted back to the sheet) which is saying <Type mismatch> when I hover the mouse over it. It doesn’t stop the code from executing, but it doesn’t paste anything.
My questions are:
How do I populate the array Arr4 with the myVal2 values, and
How do I paste it back to the sheet?
Option Explicit
Sub testArray()
Dim ArrLookupValues As Variant
ArrLookupValues = Sheet1.Range("A1:A5") 'The Lookup Values
Dim ArrLookupRange As Variant
ArrLookupRange = Sheet1.Range("C1:C5") 'The Range to find the Value
Dim ArrReturnValues As Variant
ArrReturnValues = Sheet1.Range("D1:D5") 'The adjacent Range to return the Lookup Value
Dim ArrOutput As Variant 'output array
Dim UpperElement As Long
UpperElement = UBound(ArrLookupValues) 'Used purely for the ReDim statement
Dim i As Long
For i = LBound(ArrLookupValues) To UBound(ArrLookupValues)
Dim myVal As Variant
myVal = ArrLookupValues(i, 1)
Dim pos As Variant 'variant becaus it can return an error
pos = Application.Match(myVal, ArrLookupRange, 0) 'pos always returns the correct position
Dim myVal2 As Variant
If Not IsError(pos) Then
myVal2 = ArrReturnValues(pos, 1) 'myVal2 always returns the correct value
ReDim Preserve ArrOutput(1 To UpperElement, 1 To 1)
ArrOutput(i, 1) = myVal2
Else
ReDim Preserve ArrOutput(1 To UpperElement, 1 To 1)
myVal2 = "Not Found"
ArrOutput(i, 1) = myVal2
End If
Next i
Dim Destination As Range
Set Destination = Range("B1")
Destination.Resize(UBound(ArrOutput, 1), UBound(ArrOutput, 2)).Value =
ArrOutput
End Sub
According to #T.M 's answer, you can even do that without looping just by using VLookup instead of Match:
Public Sub testArraya()
With Sheet1
Dim ArrLookupValues() As Variant
ArrLookupValues = .Range("A1:A5").Value ' lookup values 1,2,3,4,5,6
Dim ArrLookupReturnRange() As Variant ' lookup range items 2,4,6,8,10
ArrLookupReturnRange = .Range("C1:D5").Value ' And return column D a,b,c,d,e
End With
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[1] Match all values at once and return other values of column D
' (found position indices or Error 2042 if not found)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim ArrOutput() As Variant
ArrOutput = Application.VLookup(ArrLookupValues, ArrLookupReturnRange, 2, 0)
'[3] write results to any wanted target
Dim Destination As Range
Set Destination = Sheet1.Range("B1") ' ‹‹ change to your needs
Destination.Resize(UBound(ArrOutput, 1), UBound(ArrOutput, 2)).Value = ArrOutput
End Sub
Or even extremly shortened and almost a one liner:
Public Sub testArrayShort()
Const nRows As Long = 5 'amount of rows
With Sheet1
.Range("B1").Resize(nRows).Value = Application.VLookup(.Range("A1").Resize(nRows).Value, .Range("C1:D1").Resize(nRows).Value, 2, 0)
End With
End Sub
Use proper error handling and an If statement instead of On Error Resume Next.
Also your Arr4 needs to be 2 dimensional like your other arrays. Even if it is only one column it needs no be Arr4(1 To UpperElement, 1 To 1) and Arr4(i, 1) = myVal2. Ranges are always 2 dimensional (row, column) even if there is only one column.
And I highly recommend to rename your array variables. When ever you feel like you have to give your variable numbers, you can be sure you are doing it wrong.
Rename them like following for example:
Arr1 --› ArrLookupValues
Arr2 --› ArrLookupRange
Arr3 --› ArrReturnValues
Arr4 --› ArrOutput
This is only a simple modification but your code will extremely gain in human readability and maintainability. You even don't need comments to describe the arrays because their names are self descriptive now.
Finally your output array can be declared the same size as the input arrays. Using ReDim Preserve makes your code slow, so avoid using it.
So something like this should work:
Option Explicit
Public Sub testArray()
Dim ArrLookupValues() As Variant
ArrLookupValues = Sheet1.Range("A1:A5").Value
Dim ArrLookupRange() As Variant
ArrLookupRange = Sheet1.Range("C1:C5").Value
Dim ArrReturnValues() As Variant
ArrReturnValues = Sheet1.Range("D1:D5").Value
Dim UpperElement As Long
UpperElement = UBound(ArrLookupValues, 1)
'create an empty array (same row count as ArrLookupValues)
ReDim ArrOutput(1 To UpperElement, 1 To 1)
Dim i As Long
For i = LBound(ArrLookupValues, 1) To UBound(ArrLookupValues, 1)
Dim FoundAt As Variant 'variant because it can return an error
FoundAt = Application.Match(ArrLookupValues(i, 1), ArrLookupRange, 0) 'pos always returns the correct position
If Not IsError(FoundAt) Then
ArrOutput(i, 1) = ArrReturnValues(FoundAt, 1)
Else
ArrOutput(i, 1) = "Not Found"
End If
Next i
Dim Destination As Range
Set Destination = Range("B1") 'make sure to specify a sheet for that range!
Destination.Resize(UBound(ArrOutput, 1), UBound(ArrOutput, 2)).Value = ArrOutput
End Sub
Just for fun a slight modification of #PEH 's valid approach demonstrating a rather unknown way to excecute a single Match checking both arrays instead of repeated matches:
Public Sub testArray()
With Sheet1
Dim ArrLookupValues As Variant
ArrLookupValues = .Range("A1:A5").Value ' lookup values 1,2,3,4,5,6
Dim ArrLookupRange As Variant ' lookup range items 2,4,6,8,10
ArrLookupRange = .Range("C1:C5").Value
Dim ArrReturnValues As Variant ' return column D a,b,c,d,e
ArrReturnValues = .Range("D1:D5").Value
End With
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'[1] Match all item indices within ArrLookupRange at once
' (found position indices or Error 2042 if not found)
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Dim ArrOutput
ArrOutput = Application.Match(ArrLookupValues, ArrLookupRange, 0)
'[2] change indices by return values
Dim i As Long
For i = 1 To UBound(ArrOutput)
If Not IsError(ArrOutput(i, 1)) Then
ArrOutput(i, 1) = ArrReturnValues(ArrOutput(i, 1), 1)
' Else
' ArrOutput(i, 1) = "Not Found" ' optional Not Found statement instead of #NV
End If
Next i
'[3] write results to any wanted target
Dim Destination As Range
Set Destination = Sheet1.Range("B1") '<< change to your needs
Destination.Resize(UBound(ArrOutput, 1), UBound(ArrOutput, 2)).Value = ArrOutput
End Sub
this is my first foray into VBA. the follow subroutine computes a t-test for two columns of data on Sheet1.
the problem is this subroutine returns a value different from what i get when i manually run "=T.TEST(A1:A41,B1:B96,2,3)" in, say, cell D1 on the worksheet. (the numbers in the table don't really matter. i've tested with real data as well as 1 to 41 in column A1:A41 and 1 to 96 in column B1:B96.) can you confirm this? is there a bug in the code? thanks.
Sub dummy_ttest()
Dim rng0 As Range
Dim rng1 As Range
Set rng0 = Sheets("Sheet1").Range("A1:A41")
Set rng1 = Sheets("Sheet1").Range("B1:B96")
Dim td0() As Double
Dim td1() As Double
ReDim td0(rng0.Count) As Double
ReDim td1(rng1.Count) As Double
Dim i As Integer
Dim v As Variant
'copy rng0 to td0
i = 0
For Each v In rng0
td0(i) = v.value
i = i + 1
Next v
'copy rng1 to td1
i = 0
For Each v In rng1
td1(i) = v.value
i = i + 1
Next v
Dim myttest As Double
myttest = Application.WorksheetFunction.T_Test(td0, td1, 2, 3)
MsgBox myttest
End Sub
Use variant arrays and bulk load them:
Sub dummy_ttest()
Dim rng0 As Range
Dim rng1 As Range
Set rng0 = Sheets("Sheet1").Range("A1:A41")
Set rng1 = Sheets("Sheet1").Range("B1:B96")
Dim td0() As Variant
Dim td1() As Variant
td0 = rng0.Value
td1 = rng1.Value
Dim myttest As Double
myttest = Application.WorksheetFunction.T_Test(td0, td1, 2, 3)
MsgBox myttest
End Sub
Scott has an excellent answer but adding context / converting my comment to an answer:
One thing I can see is that your arrays are one element bigger than your ranges
The issue is that your arrays are 0-based, but the range is one-based. Your array is equivalent to ReDim td0(0 to rng0.Count) As Double, but the range has 1 to rng0.Count cells. It's not an issue of ReDim at all.
The range A1:A41 has 41 cells, but your array has 42 elements; 0 to 41 means you have one too many. So in your current approach, you never actually populate the last element of the array and thus it is 0 by default.
You can (and should) specify the lower bound of your arrays, i.e.
ReDim td0(0 to rng0.Count - 1) As Double '<~ 0-based
or
ReDim td0(1 to rng0.Count) As Double '<~ 1-based
From the ReDim docs:
When not explicitly stated in lower, the lower bound of an array is controlled by the Option Base statement. The lower bound is zero if no Option Base statement is present.
In Excel, I have a list of items with their weight. I've made a function in VBA which picks random items out of the list as long as the total weight is under 10.
Before this function I made an array of only zero's which should belong each to an item. When the random function picks an item, this place in the array should change into an one, but this part of the function doesn't work.
Can anyone help me to solve this problem/repair the function?
This is my code:
Sub Test()
Dim weight As Single, totWeight As Single
Dim finish As Boolean
Dim r As Integer
Const maxWeight = 10
'Here it makes an array of only zero's
Dim Arr(1 To 66) As String, i As Integer
For r = 1 To 66
Arr(r) = 0
Next r
Do Until finish = True
'Pick random row out of my Excel sheet
r = Int((65 * Rnd()) + 2)
'The first are the titles (item, weight), so that's why I start from row 2
If (totWeight + Cells(r, 2)) < maxWeight Then
'Sum the picked weight up to the total weight
totWeight = totWeight + Cells(r, 2)
'Change the position of the item in the array into a 1
'But it doesn't work
--> Arr(r) = 1
Else
'Do as long as the weight is under 10
finish = True
End If
Loop
'It only prints zero's
PrintArray Arr, ActiveWorkbook.Worksheets("Sheet1").[F1]
End Sub
(btw, this is the print function:
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1)) = Data
End Sub)
I debuged your code, and it seems that problem is in your print function. Try this one
Sub PrintArray(Data As Variant, Cl As Range)
Dim i As Integer
For i = LBound(Data) To UBound(Data)
Cl.Cells(i, 1).Value = Data(i)
Next i
End Sub
If you are interested why your solution didnt work, i think its because you tried to assign array into value. So always when need to copy array, do it item by item...
The reason it seemed like you were not putting ones into the array is because the array was oriented backwards to the way you were dumping the array elements' values back into the worksheet. Essentially, you were filling all 66 cells with the value from the first element (e.g. arr(1)). If you did this enough times, sooner or later the random r var would come out as 1 and the first element of the array would receive a 1. In this case, all of the cells would be ones.
With your single dimension array, you can use the Excel Application object's TRANSPOSE function to flip your array from what is essentially 1 row × 66 columns into 66 rows × 1 column.
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data)) = Application.Transpose(Data)
End Sub
That is a bit of a bandaid fix and the Application.Transpose has some limits (somewhere around an unsigned int - 1).
If you are creating an array for the end purpose of populating an range of cells on a worksheet, start with a 2 dimensioned array and stick with it. Keep the rank of the array correct and you won't have any problems dumping the values back into the worksheet.
Sub Test()
Dim weight As Single, totWeight As Single
Dim r As Long
Const maxWeight = 10
'Here it makes an array of only zero's
Dim Arr(1 To 66, 1 To 1) As String, i As Integer
For r = LBound(Arr, 1) To UBound(Arr, 1)
Arr(r, 1) = 0
Next r
With ActiveWorkbook.Worksheets("Sheet1")
Do While True
'Pick random row out of my Excel sheet
r = Int((65 * Rnd()) + 2)
'The first are the titles (item, weight), so that's why I start from row 2
If (totWeight + .Cells(r, 2)) < maxWeight Then
'Sum the picked weight up to the total weight
totWeight = totWeight + .Cells(r, 2)
'Change the position of the item in the array into a 1
Arr(r, 1) = 1 '<~~
Else
'just exit - no need to set a boolean
Exit Do
End If
Loop
PrintArray Arr, .Range("F2")
End With
End Sub
Sub PrintArray(Data As Variant, Cl As Range)
Cl.Resize(UBound(Data, 1), UBound(Data, 2)) = Data
End Sub
This won't make much difference with 66 rows but with respect to Luboš Suk and his excellent answer, looping through 100K cells to stuff arrayed values back into a worksheet is pretty slow by array standards and we use arrays on reasonably large data blocks because they are faster. Dumping the values back en masse is almost instantaneous.
I'm very new to VBA, to bear with me here.
I want to assign a set of variables the value of a set of ranges ie. run a brief code to simplify the following
Dim Sample 1 as string
Sample1 = activeworksheet.range("C17").value
Dim Sample 2 as string
Sample2 = activeworksheet.range("C18").value}
and so on
Following an excelfunctions.net tutorial, I know that I can shorten the declaration to
Dim Sample(1 to 20) as a string
But the tutorial drops it there(because it's a tutorial about names), suggesting I populate it as follows
sample(1)=activesheet.range("C7").value
sample(2)=activesheet.range("C7").value
and so on
I found the discussion below to be on the right track to answer my quest, but I am having trouble applying it to my situation. (Excel VBA Array Ranges for a loop)
As a follow up note, I am ultimately trying to assign values to these variables for use in the following procedures, rather than declaring and assigning them each time.
Thanks!
Try something like this:
Sub test()
Dim sampleArr(1 To 20) As String
Dim i As Integer
Dim rng As Range, cel As Range
i = 1
Set rng = Range("C1:C20")
For Each cel In rng
sampleArr(i) = cel.Value
i = i + 1
Next cel
For i = LBound(sampleArr) To UBound(sampleArr)
Debug.Print sampleArr(i)
Next i
Also, if you know the range you want to put into an array, you can simply set an array to that range:
Sub test()
Dim sampleArr() As Variant
Dim i As Integer
Dim rng As Range, cel As Range
i = 1
Set rng = Range("C1:C20") ' Note, this creates a 2 Dimensional array
sampleArr = rng ' Right here, this sets the values in the range to this array.
For i = LBound(sampleArr) To UBound(sampleArr)
Debug.Print sampleArr(i, 1) ' you need the ",1" since this is 2D.
Next i
End Sub
You should :
Define the range you want to retrieve data
For each cell of the range, retrieve your datas
dim tab() As string, cell as range, i as integer
i = 0
redim tab(0)
for each cell in ActiveWorksheet.Range("C1:C20")
tab(i) = cell
i = i + 1
redim preserve tab(i)
next
edit : I indent the code to display it correctly
Additional way to the above you can only use:
Arr = ActiveWorksheet.Range("C1:C20").Value
Then you can directly use:
Arr(i,1) where i is C1 to C20 range!