How do I write a VBA Macro that would take the power of a matrix (to an arbitrary user-specified power) that is located in cells A1 to C3?
Taking your question literally in the mathematical sense, this macro raises the matrix to a power (4 in the example) by repeatedly calling Excel's MMULT function.
Dim i As Long
Dim pow As Long
Dim vIn As Variant
Dim vOut As Variant
pow = 4 ' or whatever
' Fetch matrix from sheet
vIn = Range("A1:C3")
' Raise to power
vOut = vIn
For i = 1 To pow - 1
vOut = WorksheetFunction.MMult(vOut, vIn)
Next i
' Write result to sheet
Range("E1:G3") = vOut
I used the function below. Please note that, when the exponent is 0, the function returns the identity matrix, otherwise the matrix multiplied by itself the exponent number of times.
'Raises matrix to a power
Function PowerMatrixNew(rngInp As Range, lngPow As Integer) As Variant()
'create identitu for power 0
Dim identity() As Variant
ReDim identity(rngInp.Rows.Count, rngInp.Rows.Count)
Dim i As Integer
Dim j As Integer
For i = 1 To rngInp.Rows.Count
For j = 1 To rngInp.Rows.Count
If (i = j) Then
identity(i, j) = 1
Else
identity(i, j) = 0
End If
Next j
Next i
PowerMatrixNew = identity
For i = 1 To lngPow
PowerMatrixNew = Application.WorksheetFunction.MMult(rngInp, PowerMatrixNew)
Next
End Function
There was a question like this some years ago which I remember because it was called matrix arithmetic but not as I was taught at school.
Fill cells A1:C3 with the numbers 1 to 9. Set cell A5 to 2. Select cells A7:C9 and type
=power(A1:C3,A5) ctrl+shift+enter
and cells A7:C9 will be set to the squares of the values in A1:C3. Change A5 to 3 and cells A7:C9 will be set to the cubes of the values in A1:C3.
The equivalent in VBA is:
Range("a7:c9").FormulaArray = "=Power(a1:c3, a5)"
Related
I have a data of some binary numbers in few range of cells, from A2 to A8, B2 to B8, and so on, till G column.
Now, I want to check the largest binary number from the above Rows and paste it to the cell, two row below the last used range. (i.e., Largest binary number from Row A to be paste in A10, and so on).
I am not finding any function which can find the value of binary numbers, and the code which I ran finds out the max number considering those as natural numbers.
Your help will be appreciated.
Thank You!
Okay first i made a function that converts binary to decimal and stored in a module. (You can store it wherever you want) This function handles any size binary
Function BinToDecConverter(BinaryString As String) As Variant
Dim i As Integer
For i = 0 To Len(BinaryString) - 1
BinToDecConverter = CDec(BinToDecConverter) + Val(Mid(BinaryString, Len(BinaryString) - i, 1)) * 2 ^ i
Next
End Function
Afterwards i made the sub that loops through all binarys on sheet1 (Might need to change this for your sheet)
Sub FindLargestBinary()
On Error Resume Next
Dim wb As Workbook
Dim ws As Worksheet
Set wb = Application.ThisWorkbook
Set ws = wb.Sheets("Sheet1")
Dim tempVal, tempRow As Integer
Dim iCoulmn, iRow As Integer
For iCoulmn = 1 To 7 'Run from A to G
tempRow = 2
tempVal = 0
For iRow = 2 To 8 'Run from row 2 to 8
If BinToDecConverter(ws.Cells(iRow, iCoulmn).Value) > tempVal Then tempVal = BinToDecConverter(ws.Cells(iRow, iCoulmn).Value): tempRow = iRow ' Check if current binary i higher then any previous
Next iRow
ws.Cells(iRow + 1, iCoulmn).Value = ws.Cells(tempRow, iCoulmn).Value 'Print highest binary
Next iCoulmn
End Sub
Hope this helps you out..
You can use the excel function Bin2Dec to change them into decimal
Function MaxBin(r as range)
Dim curmax as long
Dim s as range
For each s in r
If Application.WorksheetFunction.Bin2Dec(s.Text) > curmax Then curmax = Application.WorksheetFunction.Bin2Dec(s.Text)
Next s
MaxBin = curmax
End Function
Assuming your binary values are text strings this formula converts the values to numbers, finds the MAX and then converts back to a text string
=TEXT(MAX(A2:A8+0),"00000")
confirmed with CTRL+SHIFT+ENTER
or you can use this version which finds the max using AGGREGATE function and doesn't require "array entry"
=DEC2BIN(AGGREGATE(14,6,BIN2DEC(A2:A8+0),1))
I am trying to build Lee-Ready tick test for estimating trade direction from tick data using Excel. I have a dataset containing the trade prices in descending order, and I am trying to build a VBA code that is able to loop over all the 4m+ cells in as efficient manner as possible.
The rule for estimating trade direciton goes as follows:
If Pt>Pt-1, then d=1
If Pt<Pt-1, then d=-1
If Pt=Pt-1, then d is the last value taken by d.
So to give a concrete example, I would like to transform this:
P1;P2;P3;P4
1.01;2.02;3.03;4.04
1.00;2.03;3.03;4.02
1.01;2.02;3.01;4.04
1.00;2.03;3.00;4.04
into this
d1;d2;d3;d4
1;-1;1;1
-1;1;1;-1
1;-1;1;0
0;0;0;0
Fairly straightforward nested loops suffice:
Function LeeReady(Prices As Variant) As Variant
'Given a range or 1-based, 2-dimensional variant array
'Returns an array of same size
'consisiting of an array of the same size
'of trade directions computed according to
'Lee-Ready rule
Dim i As Long, j As Long
Dim m As Long, n As Long
Dim priceData As Variant, directions As Variant
Dim current As Variant, previous As Variant
If TypeName(Prices) = "Range" Then
priceData = Prices.Value
Else
priceData = Prices
End If
m = UBound(priceData, 1)
n = UBound(priceData, 2)
ReDim directions(1 To m, 1 To n) As Long 'implicitly fills in bottom row with 0s
For i = m - 1 To 1 Step -1
For j = 1 To n
current = priceData(i, j)
previous = priceData(i + 1, j)
If current > previous Then
directions(i, j) = 1
ElseIf current < previous And previous > 0 Then
directions(i, j) = -1
Else
directions(i, j) = directions(i + 1, j)
End If
Next j
Next i
LeeReady = directions
End Function
This can be called from a sub or used directly on the worksheet:
Here I just highlighted a block of cells of the correct size to hold the output and then used the formula =LeeReady(A2:D5) (pressing Ctrl+Shift+Enter to accept it as an array formula).
On Edit: I modified the code slightly (by adding the clause And previous > 0 to the If statement in the main loop) so that it can now handle ranges in which come of the columns have more rows than other columns. The code assumes that price data is always > 0 and fills in the return array with 0s as place holders in the columns that end earlier than other columns:
Situation
I have a UDF that works with a range that it is passed that is of variable height and 2 columns wide. The first row will contain text in column 1 and an empty column2. The remainder of column 1 will contain unsorted text with an associated value in the same row in column 2. I need to sort the data such that if some text in column 1 also appears in some other text in column.
Problem
My VBA skills are all self taught and mimimal at best. I remember a few decades ago in university we did bubble sorts and played with pointers, but I no longer remember how we achieved any of that. I do well reading code but creating is another story.
Objective
I need to generate a sort procedure that will produce unique text towards the bottom of the list. I'll try wording this another way. If text in column1 can be found within other text in column, that the original text need to be placed below the other text it can be found in along with its associated data in column 2. The text is case sensitive. Its not an ascending or descending sort.
I am not sure if its a restriction of the UDF or not, but the list does not need to be written back to excel, it just needs to be available for use in my UDF.
What I have
Public Function myFunk(rng As Range) As Variant
Dim x As Integer
Dim Datarange As Variant
Dim Equation As String
Dim VariablesLength As Integer
Dim Variable As String
Datarange = rng.Value
'insert something around here to get the list "rng or Datarange" sorted
'maybe up or down a line of code depending on how its being done.
Equation = Datarange(1, 1)
For x = 2 To UBound(Datarange, 1)
VariablesLength = Len(Datarange(x, 1)) - 1
Variable = Left$(Datarange(x, 1), VariablesLength)
Equation = Replace$(Equation, Variable, Datarange(x, 2))
Next x
myFunk = rng.Worksheet.Evaluate(Equation)
End Function
Example Data
Any help with this would be much appreciated. In that last example I should point out that the "=" is not part of the sort. I have a routine that strips that off the end of the string.
So in order to achieve what I was looking for I added a SWAP procedure and changed my code to look like this.
Public Function MyFunk(rng As Range) As Variant
Dim x As Integer
Dim y As Integer
Dim z As Integer
Dim datarange As Variant
Dim Equation As String
Dim VariablesLength As Integer
Dim Variable As String
'convert the selected range into an array
datarange = rng.Value
'verify selected range is of right shape/size
If UBound(datarange, 1) < 3 Or UBound(datarange, 2) <> 2 Then
MyFunk = CVErr(xlErrNA)
Exit Function
End If
'strip the equal sign off the end if its there
For x = 2 To UBound(datarange, 1)
If Right$(datarange(x, 1), 1) = "=" Then
datarange(x, 1) = Left$(datarange(x, 1), Len(datarange(x, 1)) - 1)
End If
Next x
'sort the array so that a variable does not get substituted into another variable
'do a top down swap and repeat? Could have sorted by length apparently.
For x = 2 To UBound(datarange, 1) - 1
For y = x + 1 To UBound(datarange, 1)
If InStr(1, datarange(y, 1), datarange(x, 1)) <> 0 Then
For z = LBound(datarange, 2) To UBound(datarange, 2)
Call swap(datarange(y, z), datarange(x, z))
Next z
y = UBound(datarange, 1)
x = x - 1
End If
Next y
Next x
'Set the Equation
Equation = datarange(1, 1)
'Replace the variables in the equation with values
For x = 2 To UBound(datarange, 1)
Equation = Replace$(Equation, datarange(x, 1), datarange(x, 2))
Next x
'rest of function here
End Function
Public Sub swap(A As Variant, B As Variant)
Dim Temp As Variant
Temp = A
A = B
B = Temp
End Sub
I sorted by checking to see if text would substitute into other text in the list. Byron Wall made a good point that I could have sorted based on text length. Since I had completed this before I saw the suggestion it did not get implemented though I think it may have been a simpler approach.
I have a Custom User Function (UDF) that returns an array. I use it in an Array Formula on a large range of cells.
The length of the returned array is dependent on the function parameters.
This works great except one thing: When the length of the returned array is smaller than the range defined for the array-formula, the "out-of-range" entries are all set to #N/A.
Is there a way to either obtain the array-formula range inside the custom user function (so, if needed, I could prepare a larger array to return), or alternatively return some kind of an iterator (instead of the array) which is not limited in size and would return "" in case of out-of-range?
Here is a pretty dumb example......a UDF to return the first 7 primes in column form:
Public Function Primes()
'
' Array UDF to return the first 7 primes
'
Dim rN As Long, ary(1 To 7) As Long
Dim tdim As Long, i As Long
Dim wf As WorksheetFunction
Set wf = Application.WorksheetFunction
rN = Application.Caller.Rows.Count
tdim = wf.Max(rN, 7)
ReDim bry(1 To tdim, 1 To 1)
ary(1) = 1
ary(2) = 3
ary(3) = 5
ary(4) = 7
ary(5) = 11
ary(6) = 13
ary(7) = 17
For i = 1 To 7
bry(i, 1) = ary(i)
Next i
If tdim > 7 Then
For i = 8 To tdim
bry(i, 1) = ""
Next i
End If
Primes = bry
End Function
The UDF detects how many cells it has to fill and if that value exceeds 7, the balance is filled with blanks.
I am attempting to replicate a function for WLS (Weighted Least Squares) that I have found in a textbook in excel. There is a value error coming up and I think that I am doing something wrong in using the function.
The following is the VBA code for a supporting function Diag(w) and the function itself WLSregress():
Function Diag(W) As Variant
Dim n, i, j, k As Integer
Dim temp As Variant
n = W.Count
ReDim temp(n, n)
For i = 1 To n
For j = 1 To n
If j = i Then temp(i, j) = W(i) Else temp(i, j) = 0
Next j
Next i
Diag = temp
End Function
Function WLSregress(y As Variant, X As Variant, W As Variant) As Variant
Wmat = Diag(W)
n = W.Count
Dim Xtrans, Xw, XwX, XwXinv, Xwy As Variant
Dim m1, m2, m3, m4 As Variant
Dim output() As Variant
Xtrans = Application.Tranpose(X)
Xw = Application.MMult(Xtrans, Wmat)
XwX = Application.MMult(Xw, X)
XwXinv = Application.MInverse(XwX)
Xwy = Application.MMult(Xw, y)
b = Application.MMult(XwXinv, Xwy)
k = Application.Count(b)
ReDim output(k) As Variant
For bcnt = 1 To k
output(bcnt) = b(bcnt, 1)
Next bcnt
WLSregress = Application.Transpose(output)
End Function
This function should return the WLS estimator for the explanatory variables of equation being estimated. I understand the code leading up to the k = Application.Count(b) line but not too sure how the output bit is working.
If anyone could help me figure out why this isn't working I would be very grateful.
The following is an example image of the function trying to work.
By default, Excel will start sizing its arrays with 0 if you don't indicate otherwise. For example,
Redim arr(2,2)
will actually give you a 3 x 3 array
0 1 2
0 blank | blank | blank
1 blank | blank | blank
2 blank | blank | blank
Because of this, when you have ReDim temp(n, n), you're actually creating an array with one more row and column than you actually want. In your example, you would expect the Dialog for A3:18 to be a 16 x 16 dialog, but it will actually create a 17 x 17 dialog, throwing off your matrix multiplications (i.e. Application.MMult)
Replace this line
ReDim temp(n, n)
With this line
ReDim temp(1 to n, 1 to n)
And you should now get results returned. Up to you to determine whether the result is accurate or not.