I'm writing a macro public function for finding max of the last N non empty cells for winter months (November, December, January, February).
Here's what I got:
Public Function SuperMax_Winter(rng2 As Range, rng As Range, N As Long) As Double
Dim RngCnt, RngCnt2 As Long, i As Long, Zum As Double, j As Long
Dim ary() As Double
ReDim ary(0)
j = 0
RngCnt = rng.Count
RngCnt2 = rng2.Count
If RngCnt <> RngCnt2 Then SuperMax_Winter = "#ERROR!"
For i = RngCnt To 1 Step -1
If rng(i).Value <> "" Then
If rng2(i).Month = 11 Or rng2(i).Month = 12 Or rng2(i).Month = 1 Or rng2(i).Month = 2 Then
ary(j) = rng(i).Value
If j = N - 1 Then Exit For
ReDim Preserve ary(j + 1)
j = j + 1
End If
End If
Next i
SuperMax_Winter = Application.WorksheetFunction.Max(ary)
End Function
But I get a #VALUE! error.
I think Month should be first:
If Month(rng2(i).Value)= 11 Or Month(rng2(i).Value)= 12 Or Month(rng2(i).Value)= 1 Or Month(rng2(i).Value)= 2 Then
Hope this help.
Related
I have a table with two Columns Product and Price($).
Product
Price($)
A
100
B
400
C
350
D
50
E
515
F
140
I am trying to use vba to get combination of value of all products that will not exceed $500. I have been trying with this code and I am not sure how to proceed from this point on.
Sub getCombination()
Dim price As Long
Dim limit As Long
Dim i As Integer
Dim j As Integer
Dim combination As String
limit = 500
combination = ""
Range("B2").Activate
price = Range("B2").Value
For i = 1 To 6
For j = 1 To 6
If price <= limit Then
price = price + ActiveCell.Offset(j, 0).Value
combination = combination & ActiveCell.Offset(0, -1).Value & "," & ActiveCell.Offset(1, -1).Value
End If
Next j
Next i
ActiveCell.Offset(1, 0).Activate
MsgBox combination
End Sub
My Expected output is something like
A,B
A,C
A,C,D
B,D
C,F
A,D
C,D
(Please note: Not All output combinations are specified here!)
How should I proceed with the existing code? Or do I really have a better way for me to implement this?
Since the item can be used or not, that is a binary response. Using a binary number with the same number of digits as the number of items we can do all the combinations and do the testing:
Sub getCombination()
Dim rngArr As Variant
rngArr = ActiveSheet.Range("A2:B7")
Dim cnt As Long
cnt = 2 ^ UBound(rngArr, 1) - 1
Dim OutArray As Variant
ReDim OutArray(1 To cnt, 1 To 2)
Dim k As Long
k = 1
Dim i As Long
For i = 1 To cnt
Dim bin As String
bin = Application.Dec2Bin(i, UBound(rngArr, 1))
Dim delim As String
delim = ""
Dim j As Long
For j = 1 To UBound(rngArr, 1)
If Mid(bin, j, 1) = "1" Then
OutArray(k, 1) = OutArray(k, 1) & delim & rngArr(j, 1)
delim = ", "
OutArray(k, 2) = OutArray(k, 2) + rngArr(j, 2)
End If
Next j
If OutArray(k, 2) <= 500 Then
k = k + 1
Else
OutArray(k, 1) = ""
OutArray(k, 2) = 0
End If
Next i
Dim fnlarr As Variant
ReDim fnlarr(1 To k - 1)
For i = 1 To k - 1
fnlarr(i) = OutArray(i, 1)
Next i
Debug.Print Join(fnlarr, " | ")
End Sub
I have a sorted list of names in a single column. I would like to transform the names to 3X8 tables before printing them (printing single column would use too much paper). This is Excel. I'll copy names one by one and paste to a blank sheet.
Using numbers as an example, the resulting order should look like this:
1 9 17
2 10 18
3 11 19
4 12 20
5 13 21
6 14 22
7 15 23
8 16 24
25 33 41
26 34 42
27 35 43
........
Possible to get a general answer (n x m table)?
Below is what I have got. It's close but not quite right.
last_row = ThisWorkbook.Sheets(1).Cells(20000,1).End(xlUp).Row
For i = 1 To last_row/24 +1 Step 1
For k = 1 To 3 Step 1
For j = 1 To members_per_column Step 1
ThisWorkbook.Sheets(1).Cells( i + j + (k - 1) * 8 + (i - 1) * 16 + 1, _
name_column).Copy
Worksheets(destination_page).Cells( i + j - 1, (k - 1) +1).PasteSpecial _
Paste:=xlPasteValues
Next j
Next k
Next i
You were already close. I wrapped the code into a function so you can easily re-use it on any matrix size:
Option Explicit
Public Sub TransformIntoBlocks(ByVal MatrixRows As Long, ByVal MatrixColumns As Long, ByVal SourceRange As Range, ByVal OutputStartRange As Range)
Dim BlockStartRow As Long
BlockStartRow = 1
Dim iRowSource As Long
iRowSource = 1
Dim AmountOfBlocks As Long
AmountOfBlocks = WorksheetFunction.RoundUp(SourceRange.Rows.Count / (MatrixRows * MatrixColumns), 0)
Dim iBlock As Long
For iBlock = 1 To AmountOfBlocks
Dim iCol As Long
For iCol = 1 To MatrixColumns
Dim iRow As Long
For iRow = BlockStartRow To BlockStartRow + MatrixRows - 1
OutputStartRange.Offset(iRow - 1, iCol - 1).Value = SourceRange(iRowSource, 1).Value
iRowSource = iRowSource + 1
Next iRow
Next iCol
BlockStartRow = BlockStartRow + MatrixRows
Next iBlock
End Sub
Sub test()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1")
TransformIntoBlocks MatrixRows:=8, MatrixColumns:=3, SourceRange:=ws.Range("A1", ws.Cells(ws.Rows.Count, "A").End(xlUp)), OutputStartRange:=Tabelle2.Range("C1")
End Sub
Rather than going through three loops, I ended up just using one loop to write in the correct position using mod.
Seems obvious to me as the writer, but please ask questions if it's unclear- it helps the next reader.
Option Explicit
Sub ColumnSplit()
Dim input_rows As Integer
Dim output_columns As Integer
Dim output_rows As Integer
Dim i As Integer
Dim input_sheet As Worksheet
Dim output_sheet As Worksheet
Set input_sheet = Sheet1
Set output_sheet = Sheet2
'output_sheet.Cells.Clear 'optional
output_columns = 3 'Hard coded. Set to whatever you like
input_rows = input_sheet.Cells(Rows.Count, 1).End(xlUp).Row
output_rows = CInt(WorksheetFunction.Ceiling(CDbl(input_rows) / CDbl(output_columns), 1))
For i = 1 To input_rows
output_sheet.Cells( _
((i - 1) Mod output_rows) + 1 _
, (WorksheetFunction.Floor((i - 1) / output_rows, 1) Mod output_columns) + 1 _
) _
= input_sheet.Cells(i, 1) 'cells(calculate output row,calculate output column) = input value
Next i
End Sub
So I'm trying to compare dates in the chart pictured. I want to compare cells 1 and 2 and if the dates are the same then move to 3 and 4 and do the same comparison and then move to 5 and 6 and so on. If the dates are different I want to add 1 to a counter. Then at the end of each row I need to fill the cell at the end of the row with the 0 in it currently with the counter value and then reset the counter and move to the next row and so on. so the circled counter should read 1 because there is one pair of different dates. The code i have so far is attached. Currently it tells me "Object required" at Set CompD1. Pretty new to this so any help is appreciated.
Dim i As Integer
Dim j As Integer
Dim AdjPln As Integer
Dim CompD1 As Range
Dim CompD2 As Range
Dim cRow As Integer
For i = 0 To 49
AdjPln = 0
cRow = i + 13
For j = 0 To 9
Set CompD1 = Cells(cRow, j + 5).value
Set CompD2 = Cells(cRow, j + 6).value
If CompD1 = CompD2 Then
j = j + 2
Else
AdjPln = AdjPln + 1
j = j + 2
End If
Next j
Cells(cRow, 24) = AdjPln
Stop
Next i
I think your j loop is the issue when you tried to change the value with the formula to increment by 2 instead of 1. When you went to loop by increments other than one, you can use the Step option. In your case, you want to loop j by 2 so Step 2. You can also do negative if that is useful.
See if this works:
Dim i As Integer, j As Integer, AdjPln As Integer, cRow As Integer
For i = 0 To 49
AdjPln = 0
cRow = i + 13
For j = 0 To 9 Step 2
If Cells(cRow, j + 5).Value <> Cells(cRow, j + 6).Value Then
AdjPln = AdjPln + 1
End If
Next j
Cells(cRow, 24) = AdjPln
Next i
It appears that this could be done with a simple formula. Put this in X13 and drag down.
=SUMPRODUCT((E13:U13<>F13:V13)*(E13:U13<>"")*(F13:V13<>"")*ISODD(COLUMN(E13:U13)))
I am trying to calculate the rolling average pairwise correlation between a number of assets in excel.
I have created a custom function, and tried using the correlation matrix, but neither are satisfactory.
The assets are located in columns
Correlation must be over the defined time period/lookback
But if data is missing in part of the look back, that asset is ignored (until it has sufficient data)
So far, the function works but I cannot force it to ignore incomplete ranges (it replaces blank with 0):
Function avgRho(DataRange As Range)
'
Dim nRow As Long, nCol As Long
Dim i As Long, j As Long, j1 As Long, j2 As Long
Dim RtnData() As Double
Dim v1
Dim counts As Double, sum_correl As Double
Dim rtn1() As Double, rtn2() As Double
'
avgRho = 0
'
nRow = DataRange.Rows.Count
nCol = DataRange.Columns.Count
If nRow <= 2 Or nCol <= 1 Then Exit Function
'
ReDim RtnData(1 To nRow, 1 To nCol)
ReDim rtn1(1 To nRow)
ReDim rtn2(1 To nRow)
'
For i = 1 To nRow
For j = 1 To nCol
v1 = DataRange(i, j).Value
RtnData(i, j) = v1
Next j
Next i
'
counts = 0
sum_correl = 0
For j1 = 1 To nCol
'
For i = 1 To nRow
rtn1(i) = RtnData(i, j1)
Next i
'
For j2 = j1 + 1 To nCol
For i = 1 To nRow
rtn2(i) = RtnData(i, j2)
Next i
'
counts = counts + 1
sum_correl = sum_correl + WorksheetFunction.Correl(rtn1, rtn2)
'
Next j2
'
Next j1
'
If sum_correl > 0 Then avgRho = sum_correl / counts
'
End Function
Solved by doing similar to suggestion, thanks Peekay, filtering out blank cells when adding to the data matrix RtnData
Also changed the count process:
Function avgRho(DataRange As Range)
'
Dim nRow As Long, nCol As Long
Dim i As Integer, j As Integer, j1 As Integer, j2 As Integer
Dim RtnData() As Double
Dim v1
Dim counts As Double, sum_correl As Double
Dim rtn1() As Double, rtn2() As Double
Dim MatColCount As Integer
'
avgRho = 0
MatColCount = 0
'
nRow = DataRange.Rows.Count
nCol = DataRange.Columns.Count
If nRow <= 2 Or nCol <= 1 Then Exit Function
'
ReDim RtnData(1 To nRow, 1 To nCol)
ReDim rtn1(1 To nRow)
ReDim rtn2(1 To nRow)
'
For i = 1 To nRow
MatColCount = 0
For j = 1 To nCol
If DataRange(1, j).Value <> "" And DataRange(nRow, j) <> "" Then
v1 = DataRange(i, j).Value
MatColCount = MatColCount + 1
RtnData(i, MatColCount) = v1
End If
Next j
Next i
'
counts = 0
sum_correl = 0
If MatColCount <= 1 Then Exit Function
'
For j1 = 1 To MatColCount
For i = 1 To nRow
rtn1(i) = RtnData(i, j1)
Next i
'
For j2 = j1 + 1 To MatColCount
For i = 1 To nRow
rtn2(i) = RtnData(i, j2)
Next i
'
counts = counts + 1
sum_correl = sum_correl + WorksheetFunction.Correl(rtn1, rtn2)
'
Next j2
'
Next j1
'
If counts > 0 Then avgRho = sum_correl / counts
'
End Function
I writing a VBA plug in function to perform rectangular rounding of a series. In my VBA method I'd like to detect if there are empty cells above the cell containing the formula/VBA method. But, if I use ActiveCell in my method Excel complains of circular references and returns 0 instead of the return value of my method. Example method:
Function MovingAverageSmooth(r As Range, m As Integer)
' returns a smoothed average using the 'rectangular' method
Dim cStart As Long, x As Long, total As Double, activeColumn As Long
Dim vc As Long, vr As Long, count As Double, beforeCount As Long, afterCount As Long
vc = r.Column
vr = r.Row
rStart = Max(1, vr - m)
currentValue = Cells(vr, vc).Value
activeColumn = ActiveCell.Column
For x = rStart To vr + m
If Application.IsNumber(Cells(x, vc).Value) Then
total = total + Cells(x, vc).Value
count = count + 1
If Application.IsNumber(Cells(x, activeColumn).Value) Then
If x < vr Then
beforeCount = beforeCount + 1
End If
If x > vr Then
afterCount = afterCount + 1
End If
End If
End If
Next
MovingAverageSmooth = total / count
If afterCount = 0 Or beforeCount = 0 Or count = 0 Then
MovingAverageSmooth = currentValue
End If
End Function
I think this will work for you. As mentioned in my comment, Application.Caller returns the cell that called the function:
Function MovingAverageSmooth(r As Range, m As Integer)
' returns a smoothed average using the 'rectangular' method
Dim cStart As Long, x As Long, total As Double, activeColumn As Long
Dim vc As Long, vr As Long, count As Double, beforeCount As Long, afterCount As Long
vc = r.Column
vr = r.Row
rStart = Max(1, vr - m)
currentValue = Cells(vr, vc).Value
activeColumn = Application.Caller.Column
For x = rStart To vr + m
If Application.IsNumber(Cells(x, vc).Value) Then
total = total + Cells(x, vc).Value
count = count + 1
If Application.IsNumber(Cells(x, activeColumn).Value) Then
If x < vr Then
beforeCount = beforeCount + 1
End If
If x > vr Then
afterCount = afterCount + 1
End If
End If
End If
Next
MovingAverageSmooth = total / count
If afterCount = 0 Or beforeCount = 0 Or count = 0 Then
MovingAverageSmooth = currentValue
End If
End Function