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.
Related
Suppose I have a column of values
1
2
3
4
5
I'm trying to write a VBA function where based on what number I chose(n)
the cells will loop around to that position. So say I i chose 3
Then new list will be
4
5
1
2
3
What I have done is based on each row number, I have tried to develop rules to move the cells but it doesn't seem to be working.. I suspect it's cause I'm using activerow and not the relative row position, but I'm not sure what the syntax is for relative row. Can someone help me out
Option Explicit
Option Base 1
Function DivisibleByN(rng As Range, n As Integer) As Variant
Dim i As Integer, j As Integer
Dim nr As Integer, nc As Integer
Dim B() As Variant
Dim r As ListRow
nr = rng.Rows.Count
nc = rng.Columns.Count
r = ActiveCell.Row
ReDim B(nr, nc) As Variant
For i = 1 To nr
For j = 1 To nc
If r = 1 And r < n Then
B(nr - (n - 1), j) = rng.Cells(i, j)
ElseIf r > 1 And r < n Then
B(nr - (n - r), j) = rng.Cells(i, j)
ElseIf r > n Then
B(r - n, j) = rng.Cells(i, j)
ElseIf r = n Then
B(r, j) = rng.Cells(i, j)
End If
Next j
Next i
DivisibleByN = B
End Function
Assuming you want to "roll" each column individually, you can do something like this:
Public Sub RollColumns(ByVal rng As Range, ByVal rollBy As Integer)
Dim rowsCount As Integer, colsCount As Integer
Dim rowsOffset As Integer, colsOffset As Integer
Dim r As Integer, c As Integer
rowsCount = rng.Rows.Count
colsCount = rng.Columns.Count
rowsOffset = rng.Rows(1).Row - 1
colsOffset = rng.Columns(1).Column - 1
If rowsCount = 1 Then Exit Sub
Dim arr As Variant
arr = rng.Value
For c = 1 To colsCount
For r = 1 To rowsCount
Dim targetIndex As Integer
targetIndex = (r + rollBy) Mod rowsCount
If targetIndex = 0 Then targetIndex = rowsCount
rng.Worksheet.Cells(r + rowsOffset, c + colsOffset).Value = _
arr(targetIndex, c)
Next r
Next c
End Sub
Usage:
RollColumns Range("A1:C5"), 3
See it in action:
you could use this
Function DivisibleByN(rng As Range, n As Integer) As Variant
Dim i As Long, j As Long
With rng
ReDim B(0 To .Rows.Count - 1, 0 To .Columns.Count - 1) As Variant
For i = .Rows.Count To 1 Step -1
For j = 1 To .Columns.Count
B(i - 1, j - 1) = .Cells((.Rows.Count + i - (n + 1)) Mod .Rows.Count + 1, j)
Next
Next
DivisibleByN = B
End With
End Function
This was just to mess around with COM objects and explore them... could be tidied up. S&G moment.
Option Explicit
Public Sub test()
Const n As Long = 3 '<==Add your end point here
Dim arr(), i As Long, rng As Range
With ThisWorkbook.Worksheets("Sheet6") '<==Put your sheet name here
Set rng = .Range("A1:A5") '<== Add your single column range here
Dim maxValue As Variant
Dim minValue As Variant
maxValue = Application.Max(rng)
minValue = Application.Min(rng)
If IsError(maxValue) Or IsError(minValue) Then Exit Sub
If n > maxValue Or n < minValue Then Exit Sub
If rng.Columns.Count > 1 Then Exit Sub
If rng.Cells.Count = 1 Then
ReDim arr(1, 1): arr(1, 1) = rng.Value
Else
arr = rng.Value
End If
Dim list As Object, list2 As Object, queue As Object, arr2()
Set list = CreateObject("System.Collections.ArrayList")
Set queue = CreateObject("System.Collections.Queue")
For i = LBound(arr, 1) To UBound(arr, 1)
list.Add arr(i, 1)
Next
list.Sort
Set list2 = list.Clone
list2.Clear
arr2 = list.GetRange(n, maxValue - n).toArray
For i = LBound(arr2) To UBound(arr2)
queue.enqueue arr2(i)
Next
list2.addRange queue
queue.Clear
arr2 = list.GetRange(0, n).toArray
For i = LBound(arr2) To UBound(arr2)
queue.enqueue arr2(i)
Next
list2.addRange queue
rng.Cells(1, 1).Resize(list2.Count, 1) = Application.WorksheetFunction.Transpose(list2.toArray)
End With
End Sub
I've limited knowledge in maths so pardon the terms if i'm mistaken.
I need to create all possible combinations from multiple sets with at least 1 item included from that set.
- SetA: [1, 2, 3, 4, 5, 6, 7]
- SetB: [a, b, c, d]
- SetC: [!, #, #, $, %]
Example Output:
- [1,a,!]
- [1,2,a,c,#]
- [1,2,3,4,5,6,7,a,b,c,d,!,#,#,$,%]
Is there a specific combination formula for this since i can only come up with nested loops and i'm not sure if it is even correct.
#barrycarter had good idea of obtaining the power set. However, we don't need to reject anything as we are not getting the power set of the union of sets (this would end up being inefficient as there will be many rejects as the number of sets grows). We simply get the power set of each set, then get all combinations of those power sets. The subroutine below, works for an arbitrary number sets of arbitrary length.
Sub CreateAllCombs()
Dim ArrayOfPowSets() As Variant, mySet() As Variant, ArrCounter() As Long, myPS As Variant
Dim myCombs() As Variant, nextComb() As Variant, ParentComb() As Variant, ArrMax() As Long
Dim i As Long, j As Long, k As Long, count1 As Long, count2 As Long, CombExist As Boolean
Dim tempCol As Long, myMax As Long, maxRow As Long, totalCombs As Long
With ActiveSheet
maxRow = .Cells(.Rows.count, "A").End(xlUp).Row
End With
ReDim ArrayOfSets(1 To maxRow, 1 To 1)
ReDim ArrCounter(1 To maxRow)
ReDim ArrMax(1 To maxRow)
myMax = 0
For i = 1 To maxRow
With ActiveSheet
tempCol = .Cells(i, .Columns.count).End(xlToLeft).Column
End With
ReDim mySet(1 To tempCol)
For j = 1 To tempCol: mySet(j) = Cells(i, j): Next j
myPS = PowerSet(mySet)
ArrMax(i) = UBound(myPS)
If ArrMax(i) > myMax Then
myMax = ArrMax(i)
ReDim Preserve ArrayOfPowSets(1 To maxRow, 1 To ArrMax(i))
End If
For j = 1 To ArrMax(i)
ArrayOfPowSets(i, j) = myPS(j)
Next j
ArrCounter(i) = 1
Next i
CombExist = True
totalCombs = 0
Do While CombExist
count1 = 1
ReDim ParentComb(1 To 1)
For i = 1 To maxRow - 1
For j = 1 To UBound(ArrayOfPowSets(i, ArrCounter(i)))
ReDim Preserve ParentComb(1 To count1)
ParentComb(count1) = ArrayOfPowSets(i, ArrCounter(i))(j)
count1 = count1 + 1
Next j
Next i
For i = 1 To ArrMax(maxRow)
count2 = count1
nextComb = ParentComb
For j = 1 To UBound(ArrayOfPowSets(maxRow, i))
ReDim Preserve nextComb(1 To count2)
nextComb(count2) = ArrayOfPowSets(maxRow, i)(j)
count2 = count2 + 1
Next j
totalCombs = totalCombs + 1
ReDim Preserve myCombs(1 To totalCombs)
myCombs(totalCombs) = nextComb
Next i
k = maxRow - 1
Do While (ArrCounter(k) >= ArrMax(k))
ArrCounter(k) = 1
k = k - 1
If k = 0 Then Exit Do
Loop
If k > 0 Then ArrCounter(k) = ArrCounter(k) + 1 Else CombExist = False
Loop
Sheets("Sheet2").Select
For i = 1 To totalCombs
For j = 1 To UBound(myCombs(i))
Cells(i, j) = myCombs(i)(j)
Next j
Next i
End Sub
I used a slightly modified version of the power set function written by John Coleman found here
Function PowerSet(Items As Variant) As Variant
Dim PS As Variant
Dim i As Long, j As Long, k As Long, n As Long
Dim subset() As Variant
n = UBound(Items)
ReDim PS(1 To 1 + 2 ^ n - 2)
For i = 1 To 2 ^ n - 1
ReDim subset(1 To n)
k = 0
For j = 0 To n - 1
If i And 2 ^ j Then
k = k + 1
subset(k) = Items(j + 1)
End If
Next j
ReDim Preserve subset(1 To k)
PS(i) = subset
Next i
PowerSet = PS
End Function
This assumes that SetA is on row 1, SetB is on row 2, etc. Observe:
Additionally, the reader should be warned that this may take a while as there is over 14 million possible combinations.
(2^3 - 1) * (2^5 - 1) * (2^16 - 1) = 7 * 31 * 65535 = 14221095
Also, all combinations are written out generically to Sheet2.
I think i found my solution please verify.
First, for each sets, i created all possible combinations and checked the length using the sum of pascal triangle without the null or this formula:
n!/(r!(n-r)!) - 1
e.g.
SetB: [a, b, c, d] -> [a,b,c,d,ab,ac,ad,bc,bd,cd,abc,abd,acd,bcd,abcd]
After creating all possible combinations for each sets, I just used product rule
[SetA] X [SetB] X [SetC]
Which resulted for all possible combinations for:
multiple items
multiple sets
no repeat
no order
Reference: https://www.mathsisfun.com/combinatorics/combinations-permutations-calculator.html
EDIT1: checking for amount of combinations per set can also be (2^n)-1 where n= length of set
Have you tried using nested for loops.
Sub Hello()
MsgBox ("Hello, world!")
Dim arr1
arr1 = Array("1", "2", "3")
Dim arr2
arr2 = Array("a", "b", "c")
Dim arr3
arr3 = Array("!", "#", "$")
For i = 0 To UBound(arr1)
For j = 0 To UBound(arr2)
For k = 0 To UBound(arr3)
MsgBox (arr1(i) & arr2(j) & arr3(k))
Next
Next
Next
End Sub
I have created a function that gives me the log of the verisimilitude function in VBA ; this function requires to enter 3 parameters: Independent range(x), Dependent range(y) and betas' values (B)
option base 1
Public Function LogVerosimilitud(RangoX As Range, RangoY As Range, B As Range) As Variant
Application.Volatile
Dim n%, m%, i%, j%, k%, X() As Variant, p() As Variant, q() As Variant, g As Double, V() As Variant
Dim acumula As Double, LogVero As Double
If B.Rows.Count > B.Columns.Count Then
Application.Transpose (B)
End If
g = 0
n = RangoX.Rows.Count
m = B.Columns.Count
k = 0
ReDim X(n, m)
ReDim p(n)
ReDim q(n)
ReDim V(n)
For i = 1 To n
For j = 1 To m
If j = 1 Then
X(i, j) = 1
Else
k = k + 1
X(i, j) = RangoX(i, k)
End If
Next j
k = 0
Next i
For i = 1 To n
For j = 1 To m
g = g + X(i, j) * B(1, j)
Next j
p(i) = Exp(g) / (1 + Exp(g))
q(i) = 1 - p(i)
g = 0
Next i
For i = 1 To n
V(i) = RangoY(i) * Application.Ln(p(i)) + (1 - RangoY(i)) * Application.Ln(q(i))
Next i
LogVerosimilitud = Application.Sum(V)
End Function
Sincé I'm not able to use Solver directly in a UDF I want to run my function in an specific cell and then in another cell run an auxiliary function that call a sub in which I'm triying to run Excel's solver
Sub Solver(Target, Rango)
SolverOk SetCell:=Target.Address, MaxMinVal:=1, ValueOf:=0, ByChange:=Rango.Address, _
Engine:=1, EngineDesc:="GRG Nonlinear"
SolverSolve
End Sub
This is my auxiliary function:
Public Function LOGIT(LogVero As Range, B As Range) As Boolean
Debug.Print LogVero.Address
Debug.Print B.Address
Call Solver(LogVero.Address, B.Address)
End Function
But when running LOGIT function I got a #Value error in the cell I'm running LOGIT function
What am I doing wrong?
This how my data look like:
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
What would be the VBA code to remove blank cells randomly placed in a spreadsheet.
Input
ColA ColB ColC ColD ColE
A B D
H J I
F B O
Output Should be like:
ColA ColB ColC ColD ColE
A B D
H J I
F B O
This solution is very fast and is free from the three caveats listed in my comment below the OP question:
Public Sub CullValues()
Dim i&, j&, k&, v
v = ActiveSheet.UsedRange
For i = 1 To UBound(v, 1)
k = 0
For j = 1 To UBound(v, 2)
If Len(v(i, j)) Then
k = k + 1
v(i, k) = v(i, j)
If j > k Then v(i, j) = Empty
End If
Next
Next
[a1].Resize(UBound(v, 1), UBound(v, 2)) = v
End Sub
You should really post at least an attempt of writing the code yourself.
That said, below is a working solution.
Option Explicit
Sub remove_blanks()
Dim lrow As Long, lcol As Long, i As Long, j As Long, k As Long, r As Long
Dim arrData() As Variant
Dim wb As Workbook, ws As Worksheet, myrng As Range
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
' Range can be made dynamic
Set myrng = ws.Range("A1:BR103068")
arrData = myrng.Value
For i = LBound(arrData, 1) To UBound(arrData, 1)
r = 0
For j = LBound(arrData, 2) To UBound(arrData, 2)
If arrData(i, j) = Empty Then
For k = j To UBound(arrData, 2) - 1
arrData(i, k) = arrData(i, k + 1)
Next k
' Last element emptied after first loop
If k = UBound(arrData, 2) And r = 0 Then
arrData(i, k + r) = Empty
End If
r = r + 1 ' counts how many empty elements removed
End If
' Exits loop after spaces removed from iteration
If j + r = UBound(arrData, 2) Then
Exit For
End If
' Accounts for consecutive empty array elements
If arrData(i, j) = Empty Then
j = j - 1
End If
Next j
Next i
myrng.ClearContents
myrng.Value = arrData
End Sub
I haven't tested #Excel Hero's, but it doesn't look like it shifts all elements up the array when it finds an empty element. The below will move all elements, and then iterate to the next empty element, until it reaches a point where all elements in that item have been assessed.
Testing on 70 columns and 100,000 rows of data, the code took 80 seconds to complete.