I've got the following Macro and Function working, but the pasted result has a layer of zeroes in the left side and top of the result. hope you guys can figure out the error in my code. I am to believe the error is in the function:
Sub AutoCovariance()
Dim DataRange As Range
Dim VarCovarOutPutRange As Range
Dim NumberOfReturns As Long
Dim NumberOfStocks As Long
Dim ArrayColumnsCounter As Double
Dim ArrayRowsCounter As Double
Dim ReturnsArray() As Double
Dim DataReturns() As Variant
Dim DataRowCounter As Long
Dim DataColumnCounter As Long
Dim Stock As Long
Dim dAutoCoVar() As Double
Set DataRange = ThisWorkbook.Worksheets(Sheet1.Name).ListObjects("DataTable").DataBodyRange
NumberOfReturns = ThisWorkbook.Worksheets(Sheet1.Name).ListObjects("DataTable").DataBodyRange.Rows.Count
NumberOfStocks = ThisWorkbook.Worksheets(Sheet1.Name).ListObjects("DataTable").Range.Columns.Count
ArrayColumnsCounter = 0
ArrayRowsCounter = 0
ReDim Preserve ReturnsArray(10, 1)
' Creating returns array
For DataColumnCounter = 1 To NumberOfStocks
ArrayRowsCounter = ArrayRowsCounter + 1
For DataRowCounter = 1 To NumberOfReturns
ArrayColumnsCounter = ArrayColumnsCounter + 1
ReDim Preserve ReturnsArray(NumberOfStocks, ArrayColumnsCounter)
For Stock = 1 To NumberOfStocks
ReturnsArray(Stock, ArrayColumnsCounter) = DataRange(DataRowCounter, Stock).Value
Next Stock
Next DataRowCounter
ArrayColumnsCounter = ArrayColumnsCounter - 100
Next DataColumnCounter
' Transfer ReturnsArray Data to DataReturns
ReDim DataReturns(NumberOfReturns, NumberOfStocks)
DataReturns = Application.WorksheetFunction.Transpose(ReturnsArray)
' calculate the autocovariance matrix
dAutoCoVar = Autocovar(DataReturns)
' write to the worksheet, for debug
Set VarCovarOutPutRange = ThisWorkbook.Worksheets(Sheet1.Name).Range(Cells(1, NumberOfStocks + 2), Cells(NumberOfStocks, NumberOfStocks * 2 + 2))
VarCovarOutPutRange.Value = dAutoCoVar
End Sub
And the Function
Function Autocovar(DataReturns() As Variant) As Double()
Dim dArrResult() As Double
Dim j As Long, k As Long
' redim the result array as a square array.
ReDim dArrResult(1 To UBound(DataReturns, 2), 1 To UBound(DataReturns, 2))
' calculate the autocovariance matrix
For j = 1 To UBound(DataReturns, 2)
For k = 1 To UBound(DataReturns, 2)
With Application.WorksheetFunction
dArrResult(j, k) = .Covariance_S(.Index(DataReturns, 0, j), .Index(DataReturns, 0, k))
End With
Next k
Next j
Autocovar = dArrResult
End Function
The problem sounds typical for wrong array indices.
Your array operations all assume that the first index is 1. But by default, if you ReDim an array like this:
ReDim DataReturns(NumberOfReturns, NumberOfStocks)
the indices will start at 0.
Try adding this line at the beginning of your module:
Option Base 1
This sets the first index of all arrays not explicitely declared as Dim ar(x to y) to a base index of 1.
Related
I want to add two matrices, after I recieved one of the two by a matrix multiplication. The Formular I want to calculate is: ((TS x TI) + TI) x PK = TK
Dim TS_Matrix As Variant, TI_Matrix As Variant, Dummy_Matrix As Variant, PK_Matrix As Variant, TK_Matrix As Variant
'Read matrices
TS_Matrix = Worksheets(1).Range("B2:E5")
TI_Matrix = Worksheets(2).Range("B2:E5")
PK_Matrix = Worksheets(3).Range("B2:B5")
'Calculation
Dummy_Matrix = Application.MMult(TS_Matrix, TI_Matrix)
Dummy_Matrix = Dummy_Matrix + TI_Matrix
TK_Matrix = Application.MMult(Dummy_Matrix, PK_Matrix)
'Write
Worksheets(4).Range("B2:B5") = TK_Matrix
Without the addition it works perfectly. How do I fix it? The following line gives me a
run-time error ‘13’: Type mismatch.
Dummy_Matrix = Dummy_Matrix + TI_Matrix
Thank you in advance!
You cannot add 2 matrices like this Dummy_Matrix = Dummy_Matrix + TI_Matrix because VBA doesn't support to add 2 arrays out of the box. Instead you would need to loop through all elements of the array to add each by each.
Here is an example:
Option Explicit
Public Sub TestMatrixAdd()
Dim MatrixA As Variant
Dim MatrixB As Variant
Dim MatrixOut As Range 'note output must be a range
With Worksheets("Sheet1") 'adjust to your sheet
MatrixA = .Range("A1:B5")
MatrixB = .Range("D1:E5")
Set MatrixOut = .Range("G1:H5")
End With
MatrixOut = AddMatrices(MatrixA, MatrixB)
End Sub
Public Function AddMatrices(MatrixA As Variant, MatrixB As Variant) As Variant
'matrices must be of the same size
If LBound(MatrixA, 1) <> LBound(MatrixB, 1) Or _
LBound(MatrixA, 2) <> LBound(MatrixB, 2) Or _
UBound(MatrixA, 1) <> UBound(MatrixB, 1) Or _
UBound(MatrixA, 2) <> UBound(MatrixB, 2) Then
GoTo SIZE_ERROR
End If
Dim MatrixOut As Variant
ReDim MatrixOut(LBound(MatrixA, 1) To UBound(MatrixA, 1), LBound(MatrixA, 2) To UBound(MatrixA, 2))
'matrix addition
Dim i As Long, j As Long
For i = LBound(MatrixA, 1) To UBound(MatrixA, 1)
For j = LBound(MatrixA, 2) To UBound(MatrixA, 2)
MatrixOut(i, j) = MatrixA(i, j) + MatrixB(i, j)
Next j
Next i
AddMatrices = MatrixOut
Exit Function
SIZE_ERROR:
AddMatrices = "Matrices must be of the same size"
End Function
So the problem is more in depth than a simple comparison. Essentially im trying to model this dice roll known as the roll and keep system. Example would be 5k3. Where I would roll 5 dice and keep the 3 highest then add them together.
I've gotten my little macro program to roll the dice. Then I put them in an array in my example that would be an array with 5 indices. Now I need to take those 5 dice, and only keep the largest 3 of them.
The code is here A2 gives me the number of sides on the dice, B2 gives me how many I roll, and C2 gives me how many I keep. This rolls 10 dice, but then I transfer 5 of them into my actual dicepool. I know I could probably skip that, but I can deal with that later.
Private Sub CommandButton1_Click()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim RandNum As Integer
Dim RollArray() As Integer
Dim KeptArray() As Integer
Dim RollArrayDummy() As Integer
Dim NumRoll As Integer
Dim Kept As Integer
Dim Largest As Integer
NumRoll = Range("B2").Value
ReDim RollArray(NumRoll)
Kept = Range("C2").Value
ReDim KeptArray(Kept)
For i = 5 To 15
Randomize
RandNum = 1 + Rnd() * (Range("A2").Value - 1)
Cells(i, 1).Value = RandNum
Next i
For j = 1 To NumRoll
RollArray(j) = Cells(4 + j, 1).Value
Cells(4 + j, 2).Value = RollArray(j)
Next j
k = 1
i = 1
m = 1
Largest = 1
For k = 1 To Kept
m = 1
KeptArray(k) = Largest
If m <= NumRoll Then
If Largest >= RollArray(m) And Largest >= KeptArray(k) Then
Largest = KeptArray(k)
Else
KeptArray(k) = Largest
Largest = RollArray(m)
End If
m = m + 1
End If
Cells(4 + k, 3).Value = KeptArray(k)
Next k
End Sub
I've tried so many things, like creating a dummy array, and comparing the variable Largest with it. And a ton of other things. My big problem is that I can't reuse any of the numbers.
If I roll 5 and keep 3. Say I roll [4,2,3,3,6] . I keep the [6,4,3]. Im sure this is incredibly simple and im overlooking it but its driving me absolutely insane.
Today I was watching some MonteCarlo simulations, so I have decided to do the whole question from the beginning. Thus, imagine that this is the input:
After the first roll, this is what you get:
The values in yellow are the top 3, which are kept. This is the result from the second roll:
And here is the whole code:
Public Sub RollMe()
Dim numberOfSides As Long: numberOfSides = Range("A2")
Dim timesToRoll As Long: timesToRoll = Range("B2")
Dim howManyToKeep As Long: howManyToKeep = Range("C2")
Dim cnt As Long
Dim rngCurrent As Range
Cells.Interior.Color = vbWhite
Set rngCurrent = Range(Cells(1, 6), Cells(1, 6 + timesToRoll - 1))
For cnt = 1 To timesToRoll
rngCurrent.Cells(1, cnt) = makeRandom(1, numberOfSides)
Next cnt
Dim myArr As Variant
With Application
myArr = .Transpose(.Transpose(rngCurrent))
End With
WriteTopN howManyToKeep, myArr, Cells(2, lastCol(rowToCheck:=2))
End Sub
Public Sub WriteTopN(N As Long, myArr As Variant, lastCell As Range)
Dim cnt As Long
For cnt = 1 To N
Set lastCell = lastCell.Offset(0, 1)
lastCell = WorksheetFunction.Large(myArr, cnt)
lastCell.Interior.Color = vbYellow
Next cnt
End Sub
The makeRandom and lastCol functions are some functions that I use for other projects as well:
Public Function makeRandom(down As Long, up As Long) As Long
makeRandom = CLng((up - down + 1) * Rnd + down)
If makeRandom > up Then makeRandom = up
If makeRandom < down Then makeRandom = down
End Function
Function lastCol(Optional strSheet As String, Optional rowToCheck As Long = 1) As Long
Dim shSheet As Worksheet
If strSheet = vbNullString Then
Set shSheet = ActiveSheet
Else
Set shSheet = Worksheets(strSheet)
End If
lastCol = shSheet.Cells(rowToCheck, shSheet.Columns.Count).End(xlToLeft).Column
End Function
Instead of looping through the array "manually", the WorksheetFunction.Large() nicely returns the Nth-largest value.
And if you are willing to color the "dice", which were used to take the top score, you may add this piece:
Public Sub ColorTopCells(howManyToKeep As Long, rngCurrent As Range, myArr As Variant)
Dim colorCell As Range
Dim myCell As Range
Dim cnt As Long
Dim lookForValue As Long
Dim cellFound As Boolean
For cnt = 1 To howManyToKeep
lookForValue = WorksheetFunction.Large(myArr, cnt)
cellFound = False
For Each myCell In rngCurrent
If Not cellFound And myCell = lookForValue Then
cellFound = True
myCell.Interior.Color = vbMagenta
End If
Next myCell
Next cnt
End Sub
It produces this, coloring the top cells in Magenta:
Edit: I have even wrote an article using the code above in my blog here:
vitoshacademy.com/vba-simulation-of-rolling-dices
Try this, changed a few things:
Edited the random bit too
Private Sub CommandButton1_Click()
Dim i As Long, j As Long, k As Long
Dim RandNum As Long
Dim RollArray() As Long
Dim KeptArray() As Long
Dim NumRoll As Long
Dim Kept As Long
NumRoll = Range("B2").Value
ReDim RollArray(1 To NumRoll)
Kept = Range("C2").Value
ReDim KeptArray(1 To Kept)
For i = 5 To 15
Randomize
'RandNum = 1 + Rnd() * (Range("A2").Value - 1)
RandNum = 1 + Int(Rnd() * Range("A2").Value)
Cells(i, 1).Value = RandNum
Next i
For j = 1 To NumRoll
RollArray(j) = Cells(4 + j, 1).Value
Cells(4 + j, 2).Value = RollArray(j)
Next j
For k = 1 To Kept
KeptArray(k) = Application.WorksheetFunction.Large(RollArray, k)
Cells(4 + k, 3).Value = KeptArray(k)
Next k
End Sub
Makes use of the Excel large function
Here is my attempt to fix this problem. I left the reading cell values and writing results to the OP as I am focused on the logic of the process.
There are three main functions. DiceRollSim(), RollDie() and GetNLargestIndex() as well as a function to test the code, named Test().
DiceRollSim() runs the particular simulation given the number of sides, and number of die and the number to keep. It prints the results in the output window. DollDie() fills in an array of random values simulating the rolling of the die. Caution is needed to make sure the interval probabilities are maintained as VBA does round values when converting the result of Rnd() into integers. Finally, GetNLargestIndex() is the meat of the answer, as it takes the die roll results, creates an array of index values (the 1st, 2nd, 3rd .. ) and then sorts the array based on the values of the die rolls.
Option Explicit
Public Sub Test()
DiceRollSim 6, 15, 3
' Example, 15k3:
' Rolling 15 die.
' x(1) = 5 *
' x(2) = 4
' x(3) = 4
' x(4) = 2
' x(5) = 4
' x(6) = 5 **
' x(7) = 6 ***
' x(8) = 1
' x(9) = 4
' x(10) = 3
' x(11) = 1
' x(12) = 3
' x(13) = 5
' x(14) = 3
' x(15) = 3
' Sorting die values.
' x(7) = 6
' x(6) = 5
' x(1) = 5
' Sum of 3 largest=16
End Sub
Public Sub DiceRollSim(ByVal n_sides As Long, ByVal n_dice As Long, ByVal n_keep As Long)
Dim die() As Long, i As Long
ReDim die(1 To n_dice)
Debug.Print "Rolling " & n_dice & " die."
Call RollDie(n_sides, n_dice, die)
For i = 1 To n_dice
Debug.Print "x(" & i & ")=" & die(i)
Next i
Dim largest() As Long
Debug.Print "Sorting die values."
Call GetNLargestIndex(die, n_keep, largest)
Dim x_sum As Long
x_sum = 0
For i = 1 To n_keep
x_sum = x_sum + die(largest(i))
Debug.Print "x(" & largest(i) & ")=" & die(largest(i))
Next i
Debug.Print "Sum of " & n_keep & " largest=" & x_sum
End Sub
Public Sub RollDie(ByVal n_sides As Long, ByVal n_dice As Long, ByRef result() As Long)
ReDim result(1 To n_dice)
Dim i As Long
For i = 1 To n_dice
' Rnd() resurns a number [0..1)
' So `Rnd()*n_sides` returns a floating point number zero or greater, but less then n_sides.
' The integer conversion `CLng(x)` rounds the number `x`, and thus will not keep equal
' probabilities for each side of the die.
' Use `CLng(Floor(x))` to return an integer between 0 and n_sides-1
result(i) = 1 + CLng(WorksheetFunction.Floor_Math(Rnd() * n_sides))
Next i
End Sub
Public Sub GetNLargestIndex(ByRef die() As Long, ByVal n_keep As Long, ByRef index() As Long)
Dim n_dice As Long, i As Long, j As Long, t As Long
n_dice = UBound(die, 1)
' Instead of sorting the die roll results `die`, we sort
' an array of index values, starting from 1..n
ReDim index(1 To n_dice)
For i = 1 To n_dice
index(i) = i
Next i
' Bubble sort the results and keep the top 'n' values
For i = 1 To n_dice - 1
For j = i + 1 To n_dice
' If a later value is larger than the current then
' swap positions to place the largest values early in the list
If die(index(j)) > die(index(i)) Then
'Swap index(i) and index(j)
t = index(i)
index(i) = index(j)
index(j) = t
End If
Next j
Next i
'Trim sorted index list to n_keep
ReDim Preserve index(1 To n_keep)
End Sub
I am trying to store the values inside an array. I am facing a problem it says subscript out of range.
This is the code,
Sub Trial()
Dim HeaderArray() As Variant
Dim HeaderValue As String
Dim j As Long
Dim i as Long
set wk = Activeworkbook
lastrow_header_Config = Wk.Sheets("Config").Cells(Rows.Count, "W").End(xlUp).Row
j = 1
For i = 2 To lastrow_header_Config
HeaderValue = Wk.Sheets("Config").Range("W" & i).Value
If HeaderValue <> "" Then
HeaderArray(j - 1) = HeaderValue // Subscript out of range error
j = j + 1
End If
Next
End Sub
What is the mistake I am making. Kindly advise.
You need to declare the size of the array before trying to put data in it. Use COUNTA to find the number of cells with data in your range:
Sub Trial()
Dim HeaderArray() As Variant
Dim HeaderValue As String
Dim lastrow_Header_Config As Long
Dim j As Long
Dim i As Long
Set Wk = ActiveWorkbook
lastrow_Header_Config = Wk.Sheets("Config").Cells(Rows.Count, "W").End(xlUp).Row
ReDim HeaderArray(Application.WorksheetFunction.CountA(Wk.Sheets("Config").Range("W2:W" & lastrow_Header_Config))-1) As Variant
j = 0
For i = 2 To lastrow_Header_Config
HeaderValue = Wk.Sheets("Config").Range("W" & i).Value
If HeaderValue <> "" Then
HeaderArray(j) = HeaderValue
j = j + 1
End If
Next
End Sub
try this and see how it works for you
pay close attention to the ReDim HeaderArray(j) line and the ReDim Preserve HeaderArray(j) lines
Sub Trial()
Dim HeaderArray() As Variant
Dim HeaderValue As String
Dim j As Long
Dim i As Long
Set Wk = ActiveWorkbook
lastrow_header_Config = Wk.Sheets("Config").Cells(Rows.Count, "W").End(xlUp).Row
j = 1
ReDim HeaderArray(j) '<============= initialize your array length
For i = 2 To lastrow_header_Config
HeaderValue = Wk.Sheets("Config").Range("W" & i).Value
If HeaderValue <> "" Then
ReDim Preserve HeaderArray(j) '<================= adjust your array length to accomodate the additional info
HeaderArray(j - 1) = HeaderValue '// Subscript out of range error
j = j + 1
End If
Next
End Sub
Also you might want to read up on using the option keyword. Arrays by default have the first data point at index 0 so for example array(1) creates an array that has 1 data point, however to reference that data point you would use array(0). if you wanted the first data point in the array to be referenced using array(1), then you would use the Option Base 1 keyword at the very top of your module.
On the first pass, j = 1. Therefore you try to set HeaderArray(0) a value, while HeaderArray is probably 1 based.
You can eventually use Option Base 0, or explicitely Redim HeaderArray(0 to 10) (or whatever value you need)
I have 3 informations on a row and I can have multiple row selected. So what I'm looking for is a way to split a first time each row into an array.
That's what I'm doing here.
line = Split(msg, ",")
Then I want to for every line to split info to obtain a matrix with first identifer the line and the second is the info
ReDim pro(Ubound(line),3)
For i = 0 To Ubound(line)
pro(i) = Split(ligne(i), "/")
Next
But It throw me a mismatch error so I don't know how to do it
for example :
I have this
msg1/1250/Description,msg2/1500/Description2,msg3,45656,Desctiption3
And finally have this :
pro(0,0) = msg1
pro(0,1) = 1250
pro (1,1) = 1500
etc ...
Thank you
Not optimal in any way, but it should give you a start:
Dim RowCount As Integer
Dim i As Integer
Dim j As Integer
Dim x As Variant
Dim y As Variant
Line = "msg1/1250/Description,msg2/1500/Description2,msg3/45656/Desctiption3"
RowCount = UBound(Split(Line, ",")) + 1
ReDim pro(RowCount, 3)
For Each x In Split(Line, ",")
j = 0
For Each y In Split(x, "/")
pro(i, j) = y
j = j + 1
Next y
i = i + 1
Next x
What you have initially as pro is called a "jagged array". You can use a "double-transpose" to transform it into a 2D array. But beware that it needs that all the "line arrays" be of the same size:
Function toMatrix(msg as string)
Dim line: line = Split(msg, ",")
ReDim pro(UBound(line))
Dim i As Long
For i = 0 To UBound(line)
pro(i) = Split(line(i), "/")
Next
' transform array of arrays into a 2D array.
toMatrix = Application.Transpose(Application.Transpose(pro))
End Function
Sub Test
Dim msg As String
msg = "msg1/1250/Description,msg2/1500/Description2,msg3/45656/Desctiption3"
Dim ar
ar = toMatrix(msg) ' ar is now a 2D array
End Sub
This is how I did it:
Option Explicit
Public Sub TestMe()
Dim strInput As String
Dim arrVals As Variant
Dim arrVar As Variant
Dim arrVar2 As Variant
Dim arrResult As Variant
Dim lngCount As Long: lngCount = 0
strInput = "msg1/1250/Description,msg2/1500/Description2,msg3/45656/Desctiption3"
arrVals = Split(strInput, ",")
ReDim arrResult(UBound(arrVals), 1)
For Each arrVar In arrVals
arrVar2 = Split(arrVar, "/")
arrResult(lngCount, 0) = arrVar2(0)
arrResult(lngCount, 1) = arrVar2(1)
lngCount = lngCount + 1
Next arrVar
End Sub
That's the result:
As far as I did not see that you need a DescriptionN I have skipped it.
in one part of my code I read a matrix
Dim matr As Variant, mat As Variant, vec As Variant
matr = Worksheets("portfolio").Range("A2:K163")
now after two if-loops I would like to copy the whole row into a new matrix
For i = 1 To lngRow
For j = 2 To ingRow
If matr(i, 11) = matr(j, 11) Then
If matr(i, 4) = matr(j, 4) Then
matr(j,...)=mat(j,...)
End If
End If
Next j
Next i
How can one copy the whole row from the existing matrix to another one?
If I understand your request correctly, here is some code which should help you. I've commented it for explanation.
The main gist is this: mat grows in rows dynamically so that it can contain a new row of data from matr. Then this row is copied across.
Of course if you allow mat to be initialised to the same size as matr and have many empty rows, you can ignore all the work with ReDim and just use the loop at the bottom to copy a row.
Edit: I've edited this to take note of Preserve. From the docs, Preserve can only be used changing the last dimension. Because this isn't the case here, the data is copied to a temp array before new row is added.
Option Base 1
Sub rr()
' Initialise 2D array to a range
Dim matr As Variant
Dim rng As Range
Set rng = ActiveSheet.Range("A1:D7")
matr = rng
' Range used so column count can be fetched easily
Dim colCount As Long
colCount = rng.Columns.Count
' Initialise empty 2D array for populating with given rows from matr
Dim mat() As Variant
Dim matTemp() As Variant
' Test conditions simplified for demo
Dim someCondition As Boolean
someCondition = True
' upper bound of mat, for testing if it is dimensioned
Dim ub As Long
Dim m As Long, n As Long
Dim rowToCopy As Long
For rowToCopy = 1 To 2
If someCondition = True Then
' test if dimensioned already
ub = 0
On Error Resume Next
ub = UBound(mat)
On Error GoTo 0
If ub = 0 Then
' if no, dimension it to 1 row
ReDim mat(1, colCount)
Else
' if yes, dimension it to 1 extra row
ReDim matTemp(ub + 1, colCount)
For m = 1 To ub
For n = 1 To colCount
matTemp(m, n) = mat(m, n)
Next n
Next m
ReDim mat(ub + 1, colCount)
mat = matTemp
End If
' Assign 'columns' of 2D array matr to new array mat
For m = 1 To colCount
mat(ub + 1, m) = matr(rowToCopy, m)
Next m
End If
Next rowToCopy
End Sub