I require that users populate a UserForm with two cells. (Let's say these are cells "D1" and "F2"). I would like to use this offset between these two cells in other parts of the code (after searching for a keyword). Bear in mind users can choose any two cells on the sheet.
Try this function, please.
It will return the difference between rows and columns. If you need an absolute value, just un-comment the code lines making the difference positive:
Private Function cellsOffsetRC(Cell1 As Range, Cell2 As Range) As Variant
Dim calOff As Long, rowsOff As Long, arrOff(1) As Variant
arrOff(0) = Cell2.Row - Cell1.Row
'If arrOff(0) < 0 Then arrOff(0) = arrOff(0) * (-1)
arrOff(1) = Cell2.Column - Cell1.Column
'If arrOff(1) < 0 Then arrOff(1) = arrOff(1) * (-1)
cellsOffsetRC = arrOff
End Function
It can be checked with a test Sub like this:
Sub testCellsOffsetRC()
Dim arrOff As Variant
arrOff = cellsOffsetRC(Range("D1"), Range("F2"))
Debug.Print "Rows Offset: " & arrOff(0),"Columns Offset: " & arrOff(1)
Debug.Print Range("D1").Offset(arrOff(0), arrOff(1)).address
End Sub
Related
The main VBA procedure counts characters in table cells in a Word document. Since it can count characters different ways:
Count the "Objective" text for the selected table
Count the "Accomplishment" text for the selected table
Count both the Obj and Acc texts in each table (loop), for all tables (another loop)
I created calling procedures for each option above that calls the main procedure. This way I pass variables from the calling Sub to the main Sub. These variables (1) tell the main Sub whether I want to count what is in row 3 (objective) or in row 5 (accomplishment) or both, and (2) feed the If/then lines in the main Sub to make sure the right row is counted. At the time, it seemed elegant, in hindsight - not so much.
Word template below:
There will be text in O1 and the VBA will count it (characters, spaces + paragraphs) and output it in C1, and the C1 fill changes red or green if over/under the character limit. The same for A1 and C2 and so on for any number of following tables.
PROBLEM DESCRIPTION
The VBA was working for the actions above when I had the row/columns hard coded into various places in the code. If rows/columns were ever added/deleted from the tables, they would have to updated in multiple spots. It would be simpler if the row/column numbers were in one place and referred back to as variables, so I changed the row/col #s to public variables. Then the problem began.
In the code, I track (debug.print) what becomes of oRow (output row) & chcct (character count col) and both are 0 as the main Sub runs, despite both being initialized as 3 in the public Sub Row_Col_Num() below.
My public variables are at the top of the module before the first Sub() and denoted as Public. Sub Row_Col_Num() which contains the variable assignments is also Public. All Subs are in the same standard module.
Option Explicit
Public oRow As Integer 'row with "Objectives" text
Public aRow As Integer 'row with "Accomplishments" text
Public cOnA As Integer 'column that both obj and accmp text are in
Public cChCt As Integer 'column that the char count is output to
Public Sub Row_Col_Num()
oRow = 3
aRow = 5
cOnA = 1
cChCt = 3
Debug.Print "cchct pub sub: " & cChCt
End Sub
ATTEMPTS TO FIX PROBLEM & RESULTS
I used the variable normally and left it Public as well as the Sub that assigns the variables (oRow =3) values.
Sub TableCharCount_Obj()
'Run character count for the "Objectives" in the SELECTED table
Debug.Print "orow = " & oRow
Call TableCharCount(oRow, oRow) 'provide it 2x to make IF and FOR loop
End Sub
I tried putting the Sub() name in front of the variable when it is used, e.g. Row_Col_Num.orow, in the Sub above.
Call TableCharCount(Row_Col_Num.oRow, Row_Col_Num.oRow)
I tried the module name in front of the variable as well, e.g. Module1.orow.
Call TableCharCount(Module1.oRow, Module1.oRow)
RESULTS
#1 & #3 resulted in the macro counting the wrong row and outputting to the wrong cell.
#2 resulted in error "Expected Function or variable" at line: Call TableCharCount(Row_Col_Num.oRow, Row_Col_Num.oRow)
All 3 cases orow and cchct both continued to be 0 throughout the run.
QUESTIONS / SOLUTIONS
a) Can a Public variable (oRow) be used as an argument passed from calling Sub to called Sub as ByVal a As Integer?
b) Does Public Sub Row_Col_Num(), which assigns values to the public variables, have to be explicitly run or called to populate the variables in the other Subs w/ the correct values?
c) Should I call Public Sub Row_Col_Num() in every calling Sub before calling the main Sub?
Sub TableCharCount_Obj()
Call Public Sub Row_Col_Num() '<<< add this call
Call TableCharCount(oRow, oRow) 'provide it 2x to make IF and FOR loop
End Sub
This option seems like a bad design.
If it's not obvious, there was some mission creep as I added more capability For now, if I could get the public variables to work, it would be done. Appreciate any suggestion to get these variables to work. For the purposes of this question, I only left the code for the variable Sub, the first calling Sub and the main Sub. VBA below:
'#0 -- This creates variables for column and row number used in all the macros. Only need to change row/col number here if row/col are added/deleted
Option Explicit
Public oRow As Integer 'row with "Objectives" text
Public aRow As Integer 'row with "Accomplishments" text
Public cOnA As Integer 'column that both obj and accmp text are in
Public cChCt As Integer 'column that the char count is output to
'This assigns row/column numbers to the variables
Public Sub Row_Col_Num()
oRow = 3
aRow = 5
cOnA = 1
cChCt = 3
Debug.Print "cchct pub sub: " & cChCt End Sub
'#2
Sub TableCharCount_Obj() 'Run character count for the "Objectives" in the SELECTED table
Debug.Print "orow = " & oRow
Call TableCharCount(oRow, oRow) 'provide it 2x to make IF and FOR loop
End Sub
'other calling procedures removed
'#5
Option Explicit
Sub TableCharCount(ByVal a As Integer, ByVal b As Integer)
'Counts total characters in a cell w/in a table and outputs the number to a different cell, and colors the cell red or green if over/under the maximum number of characters.
Dim charCount, charWSCount, paraCount, charTot As Double
Dim iRng, oRng, txtRng As Word.Range
Dim i, max, s, t, x As Integer
Dim tcount, tbl As Integer
Dim DocT As Table 'for active doc tables
Debug.Print "cchct1= " & cChCt 'Debug.Print vbCr & "-----START-------" & vbCr Application.ScreenUpdating = False
If a <> b Then
tcount = ActiveDocument.Tables.Count
tbl = 1 'used in FOR loop, start w/ table #1
s = b - a '"STEP" used in FOR loop = # of rows between objectives text and accomplishments text Else
On Error GoTo ErrMsg 'handles expected user error of not selecting a table to execute on
tbl = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count 'ID the table that is selected
tcount = tbl 'prevents FOR loop from trying to run again
s = 1 '"STEP" used in FOR loop = # of rows between objectives text and accomplishments text / do not set to zero = infinite loop End If
'Debug.Print "# of Tables: " & tcount
For t = tbl To tcount 'loops thru the tables
Set DocT = ActiveDocument.Tables(t)
For x = a To b Step s 'loops thru the applicable row(s) in the table
'Debug.Print "x # start = " & x
'Debug.Print "table " & t
iRng = DocT.Cell(x, cOnA)
iRng.Select
'Count used in output
Selection.MoveLeft wdCharacter, 1, wdExtend 'computerstats requires the text itself selected, characters.count can use the whole cell selected
charWSCount = Selection.Range.ComputeStatistics(Statistic:=wdStatisticCharactersWithSpaces) 'counts bullets & space after bullet / not line breaks (paragraphs)
'Debug.Print "Comp statchar# " & charWSCount
'---------
paraCount = Selection.Range.ComputeStatistics(Statistic:=wdStatisticParagraphs)
'Debug.Print "#paras = " & paraCount
'----------
charTot = charWSCount + paraCount
'Output to table cell
i = x - 1 'output cell is 1 row above cell that is counted
Set oRng = DocT.Cell(i, cChCt).Range 'Char count ouput row,column
Debug.Print "cchct2= " & cChCt
oRng.Text = charTot
Set txtRng = DocT.Cell(i, cChCt - 1).Range '"# Char:" location row,column
txtRng.Text = "# Char:"
'Maximum # of char allowed in a cell. Used to change cell fill red or green.
max = 2000 '"Accomplishment" row (row 5) has a max of 2000
If i = 2 Then max = 1500 '"Objective" row (row 3) has a max of 1500
'Change color of cell to indicate over/under max # of characters
If charCount < max Then
oRng.Shading.BackgroundPatternColor = wdColorBrightGreen
Else: oRng.Shading.BackgroundPatternColor = wdColorRed
End If
'Debug.Print "x # end = " & x
'Debug.Print "--------Next x--------------"
Next x
'Debug.Print "------Next Table------"
Next t
ActiveDocument.Tables(tbl).Select 'attempt to move to top of 1st table if using CharCount_AllTab() or just to the top of the selected table for the other macros
Selection.GoTo What:=wdGoToBookmark, Name:="\Page" Selection.StartOf
Application.ScreenUpdating = True
Exit Sub
ErrMsg: Msgbox "Select a table by placing the cursor anywhere in the table. Press OK and try the macro again numnuts!", _
vbOKOnly, "Table not selected"
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
Context:
I have several lists in my sheet (1 column wide, 1-10 rows long). When I right click a cell in these lists, I can do several options, that all work well. I have given a name to the cell at the top of each of these lists (ex. Cell A1 has been given the name cell_1, B10 is names cell_2, etc).
I would like to know if the cell I am right clicking on is the one at the top of the list; is it named "cell_(number)"? If it is not, it checks the cell on top of that one. Does it have a name that starts with "cell_"? If not, check the one on top, etc. Until I can figure out the user clicked on an element of WHICH list.
TL;DR The actual question
I can use ActiveCell.Address, which gives me something like "A1" whether or not I have assigned a name to that cell. ActiveCell.Name gives "Sheet1!A1", so it's not much better. Any idea how to get it to return the name I have assigned instead?
Create a UDF to test the application names, it's less efficient but contains error handling within the function itself:
Sub SO()
'// Example how to call function
Debug.Print GetCellName(Range("A1"))
End Sub
Function GetCellName(myCell As Excel.Range) As Variant
Dim nameCheck As Variant
For Each nameCheck In Application.Names
If Replace(Replace(Replace(nameCheck, "=", ""), "'", ""), "!", "") = _
CStr(myCell.Parent.Name & myCell.Address) Then
GetCellName = CStr(nameCheck.Name)
Exit Function
End If
Next
GetCellName = CVErr(Excel.xlErrName)
End Function
Note you can also use this function in a worksheet cell like so:
=GetCellName(A1)
Perhaps this would work. This function returns the names assigned to a cell (or bigger range for that matter). If there's more than one name, it returns it as an array for array formula...or the user can supply an index to return only the desired name position
Public Function CellIsInRangeNames(sheetname As String, checkRange As Range, Optional itemNumber As Variant) As Variant
Dim oNM As Name
Dim oSht As Worksheet
Dim isect As Range
Dim namesCollection() As Variant
Set oSht = Worksheets(sheetname)
Dim i As Integer
i = -1
For Each oNM In oSht.Names
Set isect = Application.Intersect(Range(oNM.Name), checkRange)
If Not isect Is Nothing Then
i = i + 1
ReDim Preserve namesCollection(0 To i)
namesCollection(i) = CStr(oNM.Name)
End If
Next oNM
If i = -1 Then
'didn't find any
CellIsInRangeNames = xlErrName
ElseIf Not IsMissing(itemNumber) Then
'user wanted this instance only
If (itemNumber - 1 > UBound(namesCollection)) Or (itemNumber - 1 < LBound(namesCollection)) Then
CellIsInRangeNames = xlErrValue
Else
CellIsInRangeNames = namesCollection(itemNumber - 1)
End If
Else 'here's the list as an array
CellIsInRangeNames = namesCollection
End If
End Function
I have a database that has in excess on 200,000 rows. When I was writing a VBA script I had a database of about 20,000 rows in mind so I didn't care whether the database was filtered or not because the VBA script ran quickly. So given the realization that the database is huge and testing the VBA script I was surprised to notice how slowly it ran. So without further to say this is how my code looks like :
Set wsDB = ThisWorkbook.Sheets("DB")
Dim nameIndex As Long: nameIndex = Application.Match(name, wsDB.Rows(1), 0)
Dim formula As String
formula = "=IFERROR(AVERAGEIFS(" + GRA(nameIndex) + "," + GRA(dateIndex) + ",R2C," + GRA(cellNameIndex) + ",RC1" + "),"""")"
where GRA is a function that returns the address of the range of a column.
Private Function GRA(ByRef rngIndex As Long)
GRA = "DB!" + CStr(Range(Cells(2, rngIndex), Cells(rowNos, rngIndex)).Address(1, 1, xlR1C1, 0, 0))
End Function
So given that I now filter the table beforehand how can I adjust my code so that it ignores all the hidden rows and takes into account only what is visible. Of course I am aware that a simple dirty solution would be to simply copy the filter database and paste it in a new sheet but that will affect the performance which is what I'm trying to improve.
You can use the following function to return a range of only visible cells.
Function VisibleCells(Rng As Range) As Variant
Dim R As Range
Dim Arr() As Integer
Dim RNdx As Long
Dim CNdx As Long
If Rng.Areas.Count > 1 Then
VisibleCells = CVErr(xlErrRef)
Exit Function
End If
ReDim Arr(1 To Rng.Rows.Count, 1 To Rng.Columns.Count)
For RNdx = 1 To Rng.Rows.Count
For CNdx = 1 To Rng.Columns.Count
Set R = Rng(RNdx, CNdx)
If (R.EntireRow.Hidden = True) Or _
(R.EntireColumn.Hidden = True) Then
Arr(RNdx, CNdx) = 0
Else
Arr(RNdx, CNdx) = 1
End If
Next CNdx
Next RNdx
VisibleCells = Arr
End Function
The above code came from http://www.cpearson.com/excel/VisibleCells.aspx.
Normally I would only post code that I write however this does exactly what I was thinking.
I am trying to put the below formula into a UDF so that I can get a cumulative return when I aggregate monthly returns.
In excel the formula has to be recognized as an array so when I type it in I press Ctrl + Shift + Enter to get the {} brackets around the formula.
Does anyone know how to do this?
I want to be able to just type in returns_calc() and select the range that would fit into the returns variable below.
{=(PRODUCT(1+returns/100)-1)*100}
You can use the [ ] notation in Application.Evaluate to calculate Array Formulas in VBA. Your above formula can be called in VBA in just 1 line as shown below
Sub Sample()
MsgBox Application.Evaluate(["=(PRODUCT(1+returns/100)-1)*100"])
End Sub
Now modifying it to accept a range in a function, you may do this as well
Function returns_calc(rng As Range) As Variant
On Error GoTo Whoa
Dim frmulaStr As String
frmulaStr = "=(PRODUCT(1+(" & rng.Address & ")/100)-1)*100"
returns_calc = Application.Evaluate([frmulaStr])
Exit Function
Whoa:
returns_calc = "Please check formula string" 'or simply returns_calc = ""
End Function
EXAMPLE SCREENSHOT
Something like this
Public Function Range_Product(theRange As Variant)
Dim var As Variant
Dim j As Long
var = theRange.Value2
Range_Product = 1#
For j = LBound(var) To UBound(var)
Range_Product = Range_Product * (1 + var(j, 1) / 100)
Next j
Range_Product = (Range_Product - 1) * 100
End Function