How to convert this formula to application.worksheetfunction.sumproduct with assigning range?
Set wb2 = ThisWorkbook)
Set ws1 = wb2.Sheets("b")
Set ws17 = wb2.Sheets("c")
Set ws18 = wb.Sheets("a")
Set ws19 = wb.Sheets("d")
ws18.range("A:A")
Evaluate("SUMPRODUCT((A:A=J2)*(E:E=F:F))") + _
'Evaluate("SUMPRODUCT((A:A=J2)*(E:E>F:F)*(F:F>0))")
THANKS SO MUCH!
Converting a formula to a vba worksheet function equivalent is often possible but can be tricky as only a limited subset of functions are available. (See also here: Adding or multiplying variants in VBA)
Based on the example given, i think the following two functions should return the same result:
Sub TestEvaluate()
With Sheet1
x = .Evaluate("SUMPRODUCT((A1:A10=J2)*(E1:E10=F1:F10))")
y = .Evaluate("SUMPRODUCT((A1:A10=J2)*(E1:E10>F1:F10)*(F1:F10>0))")
End With
Debug.Print x + y
End Sub
Sub TestWorksheetFunction()
With Sheet1
a = .Range("A1:A10").Value2
e = .Range("E1:E10").Value2
f = .Range("F1:F10").Value2
Set j = .Range("J2")
End With
With Application
x = .SumProduct(.CountIf(j, a), .Delta(e, f))
y = .SumProduct(.CountIf(j, a), .Delta(.GeStep(f, e)), .Delta(.GeStep(0, f)))
End With
Debug.Print x + y
End Sub
Related
Sub CalculateWFR()
'select 1st sheet
Worksheets(1).Activate
'select range A:W
Worksheets(1).Cells.Select
Columns("A:W").Select
'copy paste sheet programare in results
Sheets("Programare").Range("A:W").Copy Destination:=Sheets("Result").Range("A:W")
'compare values from column U with column V and put +/-/= if value from U2 is higher,smaller or equals value from column V2
Dim X As Integer Dim y As Integer
X = Worksheets("Result").Range("U2").Value
y = Worksheets("Result").Range("V2").Value
If X > y Then
Worksheets("Result").Range("X2") = "+"
ElseIf X < y Then
Worksheets("Result").Range("X2") = "-"
ElseIf X = y Then
Worksheets("Result").Range("X2") = "="
End If
End Sub
I am trying to loop the above code on column X, which has over 1000 Rows. Also there are no blank spaces. How can I do this?
As #Zerk suggested try to figure out how this works.
Looping and Selecting is not required at all.
Try to think this as you were to put formula in column X and then google how to put that formula through VBA.
Sub test()
Sheets("Programare").Range("A:W").Copy Destination:=Sheets("Result").Range("A:W")
Sheets("Result").Range("X2:X1000").Formula = "=IF(U2>V2,""+"",IF(V2>U2,""-"",IF(U2=V2,""="","""")))"
End Sub
this is a simple stock price change code
my code is function(with parameters)
Function VanillaCall(S0 As Single, Exercise As Single, Mean As Single, sigma As Single, _
Interest As Single, Time As Single, Divisions As Integer, Runs As Integer) As Single
deltat = Time / Divisions
interestdelta = Exp(Interest * deltat)
up = Exp(Mean * deltat + sigma * Sqr(deltat))
down = Exp(Mean * deltat - sigma * Sqr(deltat))
pathlength = Int(Time / deltat)
piup = (interestdelta - down) / (up - down)
pidown = 1 - piup
Temp = 0
For Index = 1 To Runs
upcounter = 0
For j = 1 To pathlength
If Rnd > pidown Then upcounter = upcounter + 1
Next j
callvalue = Application.Max(S0 * (up ^ upcounter) * (down ^ (pathlength - upcounter)) - Exercise, 0) / (interestdelta ^ pathlength)
Temp = Temp + callvalue
Next Index
VanillaCall = Temp / Runs
End Function
parameters are passed from cells in excel.
i want to execute this function from button click and display return value in a cell say b12.
i have tried putting the code inside a button sub but its not working ,a call vanillacall inside sub too isnt working.
like..
private sub button1_click()
call vanillacall
end sub
Private Sub button1_click()
Range("B12").Value = vanillacall(....)
End Sub
As per your request, Pass arguments in Range like below. Below code is just for example (due to the changes in excel data)
Sub testing33()
Range("B12") = sample(Range("A5"), Range("B5"))
End Sub
Function sample(a As Range, b As Range)
sample = a.Cells.Value & ", " & b.Cells.Value
End Function
I'd do something like the below which would allow me to pick the range containing the data I want to pass to the function (as long as the range is contiguous and contains 8 cells) and pick the cell I want to output the result to.
Private Sub button1_click()
Dim inRng As Range, outRng As Range
inSelect:
Set inRng = Application.InputBox("Select Range to Calculate", Type:=8)
If inRng.Cells.Count <> 8 Then
MsgBox "Select a range with 8 cells!", vbCritical
GoTo inSelect
End If
outSelect:
Set outRng = Application.InputBox("Select Cell to Output To", Type:=8)
If outRng.Cells.Count > 1 Then
MsgBox "Select only one cell!", vbCritical
GoTo outSelect
End If
outRng.Value = VanillaCall(inRng.Cells(1), inRng.Cells(2), inRng.Cells(3), inRng.Cells(4), inRng.Cells(5), inRng.Cells(6), inRng.Cells(7), inRng.Cells(8))
End Sub
You need to get the values from the sheet and save in variables. Then pass the variables to the function. Then output the result to the sheet somewhere. You will need to adjust the range addresses and worksheet name as appropriate.
Private sub button1_click()
dim ws as worksheet
Set ws = worksheets("Sheet1") ' < change the sheet name as appropriate
dim S0 As Single
dim Exercise As Single
dim Mean As Single
dim sigma As Single
dim Interest As Single
dim Time As Single
dim Divisions As Integer
dim Runs As Integer As Single
S0 = ws.Range("B1") '< specify the cell that has this data
Exercise = ws.Range("B2") '< specify the cell that has this data
Mean = ws.Range("B3") '< specify the cell that has this data
sigma = ws.Range("B4") '< specify the cell that has this data
Interest = ws.Range("B5") '< specify the cell that has this data
Time = ws.Range("B6") '< specify the cell that has this data
Divisions = ws.Range("B7") '< specify the cell that has this data
Runs = ws.Range("B8") '< specify the cell that has this data
dim Result as Single
Result = vanillacall(S0, Exercise , Mean, sigma, Interest, Time, Divisions, Runs)
ws.Range("B10") = Result '<specify the cell where you want the result
end sub
I'm creating a sales channel map and use the .Left/.Top w/ + (.5*.width/.Height) to get the center of the images I'm connecting. I'd like to also use this method to select the cell that corresponds to this coordinate.
The only solution I can think of (and could implement, but I'd rather avoid an iterative approach) would be something like:
Sub FindCellLoc(DesiredYLocation,DesiredXLocation)
'Finds the Column Number of the X coordinate
RunningTotalX = 0
For X = 1 to 100000000
RunningTotalX = RunningTotalX + Cells(1,X).width
if RunningTotalX >= DesiredXLocation then
TargetCol = Cells(1,X).Column
Goto FoundCol
End if
Next X
FoundCol:
'Finds the Column Number of the X coordinate
RunningTotalY = 0
For Y = 1 to 100000000
RunningTotalY = RunningTotalY + Cells(Y,1).width
if RunningTotalY >= DesiredYLocation then
TargetRow = Cells(Y,0).Column
Goto FoundRow
End if
Next Y
FoundRow
Cells(TargetRow,TargetCol).Select
End Sub
I'd really appreciate any input about a non-iterative approach.
Thanks,
-E
Here is a routine to select a cell based on the x and y position:
Public Sub SelectCellByPos(x, y)
With ActiveSheet.Shapes.AddLine(x, y, x, y)
.TopLeftCell.Select
.Delete
End With
End Sub
I assume you have access to the shape object from which you got the desired locations. If so, you could do something like
Function GetCenterCell(shp As Shape) As Range
Dim lRow As Long, lCol As Long
lRow = (shp.TopLeftCell.Row + shp.BottomRightCell.Row) \ 2
lCol = (shp.TopLeftCell.Column + shp.BottomRightCell.Column) \ 2
Set GetCenterCell = shp.Parent.Cells(lRow, lCol)
End Function
Sub test()
Dim shp As Shape
Set shp = Sheet1.Shapes(1)
Debug.Print GetCenterCell(shp).Address
End Sub
That won't give you the exact middle if there isn't an exact middle. It will skew top and left as the integer division truncates (I think). But using the TopLeftCell and BottomLeftCell properties will be far superior to iterating, even if it means you're iterating through the cells in that range or some other implementation.
I have a code that allows me to copy and paste thousands of rows of information based on matching IDs. However the code does not seem to run well in a pivot table. In sheet 4, the IDs are put into a pivot table while in sheet 1 the IDs and the information are not in pivot table (Both IDs in sheet 4 and 1 are in the same column which is column A). However, the IDs appeared more than once in sheet 1. Thus, when i try to run the code, it gave an error that said Cannot enter a null value as an item or field name in pivot table report" on the line 'rngTracker.Value = arrT found below.
Sub Sample()
Dim rngTracker As Range
Dim rngMaster As Range
Dim arrT, arrM
Dim dict As Object, r As Long, tmp
With Workbooks("FAST_Aug2015_Segment_Out_V1.xlsm")
Set rngTracker = .Sheets("Sheet4").Range("A5:D43000")
Set rngMaster = .Sheets("Sheet1").Range("A2:C200000")
End With
'get values in arrays
arrT = rngTracker.Value
arrM = rngMaster.Value
'load the dictionary
Set dict = CreateObject("scripting.dictionary")
For r = 1 To UBound(arrT, 1)
dict(arrT(r, 1)) = r
Next r
'map between the two arrays using the dictionary
For r = 1 To UBound(arrM, 1)
tmp = arrM(r, 1)
If dict.exists(tmp) Then
arrT(dict(tmp), 4) = arrM(r, 3)
End If
Next r
rngTracker.Value = arrT 'Error shown on this line'
End Sub
Above is the code that i have and gave error as mention above. Would appreciate any help. Thank you. :) Below is the image of the pivot table in sheet 4. The column header called "Acc Seg" is not part of the pivot table but it is where the data will be paste from sheet 1 when both IDs in sheet 4 and sheet 1 matched.
Option Explicit
Public Sub Sample()
Const T As Long = 43000
Const M As Long = 200000
Dim arrT1 As Variant, arrM1 As Variant, rngT2 As Range
Dim arrT2 As Variant, arrM2 As Variant, dict As Object, r As Long
With Workbooks("TEST2.xlsm") 'get values in arrays
Set rngT2 = .Sheets("Sheet4").Range("D5:D" & T)
arrM1 = .Sheets("Sheet1").Range("A2:A" & M)
arrM2 = .Sheets("Sheet1").Range("C2:C" & M)
arrT1 = .Sheets("Sheet4").Range("A5:A" & T)
arrT2 = rngT2
End With
Set dict = CreateObject("Scripting.Dictionary")
For r = 1 To UBound(arrT1) 'load the dictionary
dict(arrT1(r, 1)) = r
Next r
For r = 1 To UBound(arrM1, 1) 'map between the arrays using the dictionary
If dict.exists(arrM1(r, 1)) Then arrT2(dict(arrM1(r, 1)), 1) = arrM2(r, 1)
Next r
rngT2 = arrT2
End Sub
I am having trouble figuring out how to subtract two ranges from each other, some cells in range H:H have "#N/A" while in range D:D there are no errors. I know in Excel it's a simple "=H2-D2" and drag that down but I'm in the process of recording a Macro and wanted to automate the subtraction as well. So far this is what I have:
Dim quantity1, quantity2, rIntersect, Qdiff, x As Range
Set quantity1 = Range("D:D")
Set quantity2 = Range("H:H")
Set rIntersect = Intersect(quantity1, quantity2)
For Each x In quantity1
If Intersect(rIntersect, x) Is Nothing Then
If Qdiff Is Nothing Then
Set Qdiff = x
Else
Set Qdiff = Application.Union(Qdiff, x)
End If
End If
Next x
Range("J2").Select
Dim lastRowJ As Long
lastRowJ = Range("A" & Rows.Count).End(xlUp).Row
Range("J2").AutoFill Destination:=Range("J2:J" & lastRowJ)
Place this procedure in a standard code module:
Public Sub Subtract()
[j2:j99] = [h2:h99-d2:d99]
End Sub
If you like how that works, I'm happy to embellish it so that it is not hard-coded for 98 rows only. Let me know.
UPDATE
Here is a version that will deal with any number of rows. It keys off of column D. So if there are 567 numbers in column D, then you will get 567 corresponding (subtracted) results in column J.
This assumes that the data start in row 2, and that there are no blank cells until the numbers in column D end.
If you are going to call this from the Macro Dialog then you should keep it Public. If on the other hand you are going to call it from another procedure in the same module, then you can make it Private.
Here is the enhanced solution:
Public Sub Subtract()
Dim k&
Const F = "iferror(h2:h[]-d2:d[],0)"
k = [count(d:d)]
[j2].Resize(k) = Evaluate(Replace(F, "[]", k + 1))
End Sub
Note that the routine now handles the errors and places a ZERO value in column J when the corresponding value in column H is an error. If you would prefer to have something other than a ZERO (like a blank for instance) when there are errors in column H, just let me know and I'll update to whatever you want.
UPDATE 2
Here is how to handle displaying blanks instead of zeroes:
Public Sub Subtract()
Dim k&
Const F = "iferror(if(h2:h[]-d2:d[]=0,"""",h2:h[]-d2:d[]),0)"
k = [count(d:d)]
[k2].Resize(k) = Evaluate(Replace(F, "[]", k + 1))
End Sub