I have created a functon to return matrix correlation of a data set, but I want this matrix to have colors like the one you can do using R o Python
Function MCORRELATION(Rango As Range) As Variant
Dim x As Variant, y As Variant, s As Integer, T As Integer, C() As Variant
ReDim C(Rango.Columns.Count, Rango.Columns.Count)
For i = 1 To Rango.Columns.Count Step 1
For j = 1 To i Step 1
C(i, j) = Application.Correl(Application.Index(Rango, , i),
Application.Index(Rango, , j))
Next j
Next i
MCORRELATION = C
End Function
How can I achieve that using conditional formating with VBA?
Related
I do some macro and i upgrade a macro of Diedrich to have a MaxIfs in excel 2010 which work with line an columns i put the code under.
Public Function maxifs(MaxRange As Range, ParamArray Criteria() As Variant) As Variant
Application.Volatile
Dim n As Long
Dim i, j As Long
Dim c As Variant
Dim f As Boolean
Dim w() As Long
Dim k As Long
Dim z As Variant
'Error if less than 1 criteria
On Error GoTo ErrHandler
n = UBound(Criteria)
If n < 1 Then
'too few criteria
GoTo ErrHandler
End If
'Define k
k = 0
'Loop through cells of max range
For i = 1 To MaxRange.Count
For j = 1 To MaxRange.Count
'Start by assuming there is a match
f = True
'Loop through conditions
For c = 0 To n - 1 Step 2
'Does cell in criteria range match condition?
If Criteria(c).Cells(i, j).Value <> Criteria(c + 1) Then
f = False
End If
Next c
'Define z
z = MaxRange
'Were all criteria satisfied?
If f = True Then
k = k + 1
ReDim Preserve w(k)
w(k) = z(i, j)
End If
Next j
Next i
maxifs = Application.Max(w)
Exit Function
ErrHandler:
maxifs = CVErr(xlErrValue)
End Function
So now i will do the minifs and it does not work if all my value are positives.
How can i do?
ps: if you change in this macro max by median it will work too
Thanks for your answers.
It is because you are starting the array w with an empty slot at 0, since the first slot you fill is slot 1.
So w(0) is 0, Which when all the others are positive it is the minimum number.
So change K=-1 instead of K=0 When initially assigning value to k.
I also moved z in front of the loop, there is no reason to keep assigning that array. It only needs to be assigned once.
Also, I changed the ranges a little to only look at the used range, this way you can use full column references.
Also, the loops need to be through the rows and columns not two loops through the whole range as it causes many unnecessary loops.
Public Function minifs(MaxRange As Range, ParamArray Criteria() As Variant) As Variant
Application.Volatile
Dim n As Long
Dim i, j As Long
Dim c As Variant
Dim f As Boolean
Dim w() As Long
Dim k As Long
Dim z As Variant
'Error if less than 1 criteria
On Error GoTo ErrHandler
n = UBound(Criteria)
If n < 1 Then
'too few criteria
GoTo ErrHandler
End If
'Define z
z = Intersect(MaxRange, MaxRange.Parent.UsedRange).Value
'Define k
k = -1
'Loop through cells of max range
For i = 1 To UBound(z, 1)
For j = 1 To UBound(z, 2)
'Start by assuming there is a match
f = True
'Loop through conditions
For c = 0 To n - 1 Step 2
'Does cell in criteria range match condition?
If Intersect(Criteria(c), Criteria(c).Parent.UsedRange).Cells(i, j).Value <> Criteria(c + 1) Then
f = False
End If
Next c
'Were all criteria satisfied?
If f = True Then
k = k + 1
ReDim Preserve w(k)
w(k) = z(i, j)
End If
Next j
Next i
minifs = Application.Min(w)
Exit Function
ErrHandler:
minifs = CVErr(xlErrValue)
End Function
Also a note as this will only do = in the criteria and not any other function like >,<,<>,....
I am trying to calculate Mahalanobis distances in VBA.
I have created my UDF to calculate Covarince matrix but i got a #value error when executing my function.
could you give me some help
Thanks in advance!
Function DMahalanobis(x As Range, y As Range) As Variant
Dim c() As Variant, k As Variant, U As Range, a() As Variant, b() As Variant
Set U = Application.Union(x, y)
Debug.Print U
k = x.Columns.Count
a = x
b = y
ReDim c(1, k)
For i = 1 To k Step 1
c(1, i) = a(1, i) - b(1, i)
Next i
DMahalanobis = Application.MMult(Application.MMult(Application.Transpose(c), Application.MInverse(MVARCOVAR(U))), c)
End Function
This is my VarCovar function that works fine
'Function to calculate Covariance matrix
Function MVARCOVAR(RANGO As Range) As Variant
Dim c() As Variant, i As Long, k As Long, j As Long
k = RANGO.Columns.Count
Debug.Print k
ReDim c(k, k)
For i = 1 To k Step 1
For j = 1 To k Step 1
c(i, j) = Application.Covar(Application.Index(RANGO, , i), Application.Index(RANGO, , j))
Next j
Next i
MVARCOVAR = c
End Function
may due to the singular issue in the line:
DMahalanobis = Application.MMult(Application.MMult(Application.Transpose(c), Application.MInverse(MVARCOVAR(U))), c).
Based on your given input, dimension of U is 2xk, as 2<<k, the covariance matrix of U may contain some missing value, when you take the inverse, it will pop up an error. Maybe you can try to change U to the whole data set, otherwise you cannot capture the distribution information in the data when calculating mahalanobis distance.
I wanted to create function that mimics standard Excel MMULT function for multiplying matrices. My code is:
Function MatrixMultiplication(Matrix1 As Range, Matrix2 As Range)
Dim m1() As Long, m2() As Long, m3() As Long
m1 = Matrix1
m2 = Matrix2
If Matrix1 Is Nothing Or Matrix2 Is Nothing Then GoTo Err1
If UBound(m1, 2) <> UBound(m2, 1) Then GoTo Err2
ReDim m3(UBound(m1, 1), UBound(m2, 2))
For i = LBound(m1) To UBound(m1, 1)
For j = LBound(m2) To UBound(m1, 2)
For k = 1 To UBound(m1, 2)
m3(i, j) = m3(i,j)+ m1(i, k) * m2(k, i)
Next k
Next j
Next i
Dim Matrix3 As Range
Set Matrix3 = Range(ActiveCell.Address, ActiveCell.Offset(UBound(m1, 1) - 1, UBound(m2, 2) - 1))
Matrix3 = m3
Set MatrixMultiplication = Matrix3
Err1:
Selection.Cells(0, 0).Value = CVErr(xlErrNull)
Err2:
Selection.Cells(0, 0).Value = CVErr(xlErrNA)
End Function
Somehow it does not work. It should work as CSE function. Thanks for any help.
Here is a version that works. A somewhat subtle point is that if you pass it arrays which are given in ranges then you need to convert them to regular arrays. Note the two lines near the beginning of the function that do that:
Function MatrixProduct(A As Variant, B As Variant) As Variant
'Assumes that A,B are 1-based variant arrays
'Or ranges containing such things.
'Little error checking is done
Dim m As Long, n As Long, p As Long, i As Long, j As Long, k As Long
Dim C As Variant
If TypeName(A) = "Range" Then A = A.Value
If TypeName(B) = "Range" Then B = B.Value
m = UBound(A, 1)
p = UBound(A, 2)
If UBound(B, 1) <> p Then
MatrixProduct = "Not Defined!"
Exit Function
End If
n = UBound(B, 2)
ReDim C(1 To m, 1 To n)
For i = 1 To m
For j = 1 To n
For k = 1 To p
C(i, j) = C(i, j) + A(i, k) * B(k, j)
Next k
Next j
Next i
MatrixProduct = C
End Function
This can be used directly in the spreadsheet and also be used directly in VBA code. It is almost definitely slower then the built-in MMULT, so I'm not quite sure how useful it is.
What I am trying to do is develop a model that takes a cell that is greater than 1 then to take the sum of the area to the first row using a cone shape, so for example cell D4, sum the area C3:C5 + B2:B6 + A1:A7.
At the moment I have this but it obviously is not working.
Dim I As Double
Dim J As Double
Dim Size As Integer
Dim x As Integer
Dim y As Integer
Dim z As Integer
'Dim Range As Integer
Dim PV1 As Integer
'MCArray = Worksheets("Data")
I = WorksheetFunction.CountA(Worksheets("Data").Rows(1))
J = WorksheetFunction.CountA(Worksheets("Data").Columns(1))
'Loop to Move down the rows
For x = 1 To J
'Loop to move acoss the columns
For y = 1 To I
'IfElse to determine if cell value is greater or equal to zero
If Cells(J, I).Value >= 0 Then
'Loop to sum the cells above
For z = 1 To J
PV1 = (ActiveCell.Value) + Worksheet.Sum(Range([J - z], [I-z:I+z]))
'IfElse to determine if final sum is greater than zero
If PV1 > 0 Then
Worksheets("MC").Range("B4").Value = PV1
Range([J - z], [I-z:I+z]).Interior.ColourIndex = 1
End If
Next z
End If
Next y
Next x
Here is a function you can use either as a UDF or from another routine. Just pass it the single cell you want to start from (D4 in your example) and this function will calculate the sum of the cone as you described.
Public Function SUMCONE(r As Range) As Double
Application.Volatile
SUMCONE = Application.Sum(r, r(-0, -0).Resize(, 3), r(-1, -1).Resize(, 5), r(-2, -2).Resize(, 7))
End Function
Here is an example of how to use the above function from your VBA routine:
Public Sub Demo()
Dim j&
For j = 5 To 10
If Cells(5, j) > 0 Then
Debug.Print SUMCONE(Cells(5, j))
End If
Next
End Sub
UPDATE
Based on your feedback I have updated the function and the demo routine to form an upward cone summation from the initial cell.
UPDATE #2
The above is for a fixed-size cone, extending upwards, that can be initiated from any cell in the worksheet.
But if you would prefer for the cone to always extend all the way up to row 1 regardless of which cell it originates in, then the following is what you are after:
Public Sub Demo()
Dim i&, j&
For j = 1 To Application.CountA(Worksheets("Data").Rows(1))
For i = 1 To Application.CountA(Worksheets("Data").Columns(1))
If Cells(i, j) > 0 Then
Debug.Print Cells(i, j).Address, SumAndColorCone(Cells(i, j))
End If
Next
Next
End Sub
Public Function SumAndColorCone(r As Range) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
k = k + 1
Next
c.Interior.Color = vbRed
SumAndColorCone = Application.Sum(c)
End Function
UPDATE #3
As I suspected there was a problem if the cone was initiated too close to the left edge of the worksheet. I've added code to handle that now. Also your method for accessing the large matrix (which I had used in the Demo routine) did not work properly. I fixed that as well:
Public Sub Demo()
Dim i&, j&
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Val(Cells(i, j)) > 0 Then
Debug.Print Cells(i, j).Address, SumAndColorCone(Cells(i, j))
End If
Next
Next
End Sub
Public Function SumAndColorCone(r As Range) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
If r.Column - k < 2 Then Exit For
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
k = k + 1
Next
c.Interior.Color = vbRed
SumAndColorCone = Application.Sum(c)
End Function
I need help with a macro that exports all combinations of a range in same row each one ( I mean horizontal exports).
Every combination I want to be in one cell each time.
I want to change any time the number of strings in the range and also the number of strings combinations (In the example below 4 strings in the range and 3 for combinations)
1. A B C D -------------ABC --ABD--ACD--BCD
2. E F G H--------------EFG---EFH--EGH--FGH
3. I G K L----------------IGK----IGL---IKL---GKL
Below its a module that I found in web that is very close to what I need.
I am very new to Vba macros and I cannot achieve what I am looking for with the below code
Private NextRow As Long
Sub Test()
Dim V() As Variant, SetSize As Integer, i As Integer
SetSize = Cells(2, Columns.count).End(xlToLeft).Column
ReDim V(1 To SetSize)
For i = 1 To SetSize
V(i) = Cells(2, i).Value
Next i
NextRow = 4
CreateCombinations V, 3, 3
End Sub
Sub CreateCombinations( _
OriginalSet() As Variant, _
MinSubset As Integer, MaxSubset As Integer)
Dim SubSet() As Variant, SubSetIndex As Long
Dim SubSetCount As Integer, Bit As Integer
Dim k As Integer, hBit As Integer
Dim MaxIndex As Long
hBit = UBound(OriginalSet) - 1
ReDim SubSet(1 To UBound(OriginalSet))
MaxIndex = 2 ^ UBound(OriginalSet) - 1
For SubSetIndex = 1 To MaxIndex
SubSetCount = BitCount(SubSetIndex)
If SubSetCount >= MinSubset And SubSetCount <= MaxSubset Then
k = 1
For Bit = 0 To hBit
If 2 ^ Bit And SubSetIndex Then
SubSet(k) = OriginalSet(Bit + 1)
k = k + 1
End If
Next Bit
DoSomethingWith SubSet, SubSetCount
End If
Next SubSetIndex
End Sub
Sub DoSomethingWith(SubSet() As Variant, ItemCount As Integer)
Dim i As Integer
For i = 1 To ItemCount
Cells(NextRow, i) = SubSet(i)
Next i
NextRow = NextRow + 1
End Sub
Function BitCount(ByVal Pattern As Long) As Integer
BitCount = 0
While Pattern
If Pattern And 1 Then BitCount = BitCount + 1
Pattern = Int(Pattern / 2)
Wend
End Function
Here is a way to do it:
In your excel sheet, add an array formula like this:
A B C D E
1
2 A B C D {=k_combinations(CONCATENATE(A2;B2;C2;D2);3)}
3 E F G H {=k_combinations(CONCATENATE(A3;B3;C3;D3);3)}
Note that you should extend the array formula to columns F, G, H and so on so that you get all results. (The { and } are not to be inserted manually, they are the mark of the array formula) :
Select cells E2, F2, G2, H2, and so on to Z2
Type the formula
To validate input, press Ctrl+Shift+Enter
Put the following code into a code module.
Public Function k_combinations(ByVal chLetters As String, ByVal k As Long) As Variant
Dim chCombinations() As String
Dim uCount As Long
Dim vReturn() As Variant
Dim i As Long
uCount = Get_k_combinations(chLetters, chCombinations, k)
ReDim vReturn(0 To uCount - 1) As Variant
For i = 0 To uCount - 1
vReturn(i) = chCombinations(i)
Next i
k_combinations = vReturn
End Function
Private Function Get_k_combinations(chLetters As String, chCombinations() As String, ByVal k As Long) As Long
Dim i As Long
Dim M As Long
M = Len(chLetters)
If k > 1 Then
Get_k_combinations = 0
For i = 1 To M - (k - 1)
Dim chLetter As String
Dim uNewCombinations As Long
Dim chSubCombinations() As String
Dim j As Long
chLetter = Mid$(chLetters, i, 1)
uNewCombinations = Get_k_combinations(Right$(chLetters, M - i), chSubCombinations, k - 1)
ReDim Preserve chCombinations(0 To Get_k_combinations + uNewCombinations) As String
For j = 0 To uNewCombinations - 1
chCombinations(Get_k_combinations + j) = chLetter & chSubCombinations(j)
Next j
Get_k_combinations = Get_k_combinations + uNewCombinations
Next i
Else
ReDim chCombinations(0 To M - 1) As String
For i = 1 To M
chCombinations(i - 1) = Mid$(chLetters, i, 1)
Next i
Get_k_combinations = M
End If
End Function
Get_k_combinations is called recursively. The performance of this method is quite poor (because it uses string arrays and makes a lot of reallocations). If you consider bigger data sets, you will have to optimize it.