I need to assign a unique name to a cell which calls a particular user defined function.
I tried
Dim r As Range
set r = Application.Caller
r.Name = "Unique"
The following code sets cell A1 to have the name 'MyUniqueName':
Private Sub NameCell()
Dim rng As Range
Set rng = Range("A1")
rng.Name = "MyUniqueName"
End Sub
Does that help?
EDIT
I am not sure how to achieve what you need in a simple way, elegant way. I did manage this hack - see if this helps but you'd most likely want to augment my solution.
Suppose I have the following user defined function in VBA that I reference in a worksheet:
Public Function MyCustomCalc(Input1 As Integer, Input2 As Integer, Input3 As Integer) As Integer
MyCustomCalc = (Input1 + Input2) - Input3
End Function
Each time I call this function I want the cell that called that function to be assigned a name. To achieve this, if you go to 'ThisWorkbook' in your VBA project and select the 'SheetChange' event then you can add the following:
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
If Left$(Target.Formula, 13) = "=MyCustomCalc" Then
Target.Name = "MyUniqueName"
End If
End Sub
In short, this code checks to see if the calling range is using the user defined function and then assigns the range a name (MyUniqueName) in this instance.
As I say, the above isn't great but it may give you a start. I couldn't find a way to embed code into the user defined function and set the range name directly e.g. using Application.Caller.Address or Application.Caller.Cells(1,1) etc. I am certain there is a way but I'm afraid I am a shade rusty on VBA...
I used this sub to work its way across the top row of a worksheet and if there is a value in the top row it sets that value as the name of that cell. It is VBA based so somewhat crude and simple, but it does the job!!
Private Sub SortForContactsOutlookImport()
Dim ThisCell As Object
Dim NextCell As Object
Dim RangeName As String
Set ThisCell = ActiveCell
Set NextCell = ThisCell.Offset(0, 1)
Do
If ThisCell.Value <> "" Then
RangeName = ThisCell.Value
ActiveWorkbook.Names.Add Name:=RangeName, RefersTo:=ThisCell
Set ThisCell = NextCell
Set NextCell = ThisCell.Offset(0, 1)
End If
Loop Until ThisCell.Value = "Web Page"
End Sub
I use this sub, without formal error handling:
Sub NameAdd()
Dim rng As Range
Dim nameString, rangeString, sheetString As String
On Error Resume Next
rangeString = "A5:B8"
nameString = "My_Name"
sheetString = "Sheet1"
Set rng = Worksheets(sheetString).Range(rangeString)
ThisWorkbook.Names.Add name:=nameString, RefersTo:=rng
End Sub
To Delete a Name:
Sub NameDelete()
Dim nm As name
For Each nm In ActiveWorkbook.Names
If nm.name = "My_Name" Then nm.Delete
Next
End Sub
Related
I am trying to write a VBA code such that a Message box pops up whenever the value inside certain cells change.
The cells that I want to monitor change because they are linked to a query which is refreshed automatically. The VBA codes I found online only work when the cell value is changed manually, this will not work because the formula in the cells do not change, only the displayed value changes.
Can anyone help me with this?
Application Calculate (Public Variables)
The following is written for a non-contiguous range.
A message box pop's up each time a value in the range changes via formula.
Copy the codes into the appropriate modules.
Adjust the values in the constants section.
This is an automated solution. To start you should either save, close, and reopen the workbook or run the popupMsgBoxInit procedure.
Standard Module e.g. Module1
Option Explicit
Public Const popupWsName As String = "Sheet1"
Public Const popupRgAddress As String = "A1,C3,E5"
Public popupRg As Range
Public popupCount As Long
Public popupArr As Variant
Sub popupMsgBoxInit()
Set popupRg = ThisWorkbook.Worksheets(popupWsName).Range(popupRgAddress)
popupRg.Interior.Color = 65535 'xlNone
popupCount = popupRg.Cells.Count
ReDim popupArr(1 To popupCount)
Dim cel As Range
Dim i As Long
For Each cel In popupRg.Cells
i = i + 1
popupArr(i) = cel.Value
Next cel
End Sub
Sub popupMsgBox()
Dim chCount As Long
Dim cel As Range
Dim i As Long
For Each cel In popupRg.Cells
i = i + 1
If cel.Value <> popupArr(i) Then
chCount = chCount + 1
popupArr(i) = cel.Value
End If
Next cel
MsgBox "Number of Changes: " & chCount, vbInformation, "Success"
End Sub
ThisWorkbook Module
Option Explicit
Private Sub Workbook_Open()
popupMsgBoxInit
End Sub
Sheet Module e.g. Sheet1
Option Explicit
Private Sub Worksheet_Calculate()
popupMsgBox
End Sub
I have a formula that makes an API request every time it's executed, which makes it slow. I'd like to prevent Excel from automatically recalculating cells containing this formula but still automatically recalculate other cells.
I've tried setting calculation mode to Manual with:
Application.Calculation = xlCalculationManual
However this prevents other cells without my formula from calculating automatically.
Another idea I've had is to check if a cell has been "frozen" and then return it's current value instead of calling the API for a new value. The issue with this is that Excel doesn't provide a way to exit the function without altering the cell value.
Function MyFormula() As Variant
If CellIsFrozen() Then
MyFormula = Application.Caller.Value 'return current value
Else
MyFormula = GetNewValueFromAPI() 'expensive call to server
End If
End Function
My issue with the above is that Application.Caller.Value returns the cell value by performing a recalculation and results in an infinite recursion.
FYI - the CellIsFrozen method is just an example sub that would somehow check whether the cell was called automatically or manually.
I'm also aware of Application.Caller.Value2 and .text, unfortunately these don't help me. Value2 also causes a recalculation, and text just returns a string representation (which is not useful because it could be "######" if the value is a date and the column is too narrow).
Is there a way to interrupt Excel's recalculation process for specific formulas?
Otherwise, is it possible to extract a value of a cell without performing a recalculation - I'm guessing that Excel stores the value somewhere because it's visible on the worksheet, it makes no sense to insist on recalculating every time.
In the context my previous answer to the post involving single cell, i also want share our old experience involving multiple cells. that days We used the formula in an indexed fashion like =myformula(1)... etc and stored it in a global array. Now today thanks to your great idea of Caller function. I recreated another improvised solution involving multiple cells.
Here again in module1
Global Flag As Boolean, LastValArr(1 To 10, 1 To 2) As Variant, Ws As Worksheet, Rng As Range
Public Function MyFormula() As Variant
Dim Adr As String, X As Integer
If Flag Then
MyFormula = GetNewValueFromAPI() 'expensive call to server
Else
Adr = Application.Caller.Address
For X = 1 To 10
If InStr(1, LastValArr(X, 2), Adr) > 0 Then
MyFormula = LastValArr(X, 1)
Exit For
End If
Next
End If
End Function
Function GetNewValueFromAPI() As Variant
GetNewValueFromAPI = Application.WorksheetFunction.RandBetween(1, 1000)
End Function
Sub CalcA1()
Flag = True
Rng.Dirty
Flag = False
Ws.Range("F1").Value = IIf(Flag, "On", "Off")
End Sub
Sub ToggleFlag()
Flag = Not Flag
Ws.Range("F1").Value = IIf(Flag, "On", "Off")
If Flag Then Rng.Dirty
End Sub
in Workbook_Open event
Private Sub Workbook_Open()
Dim X As Integer
Dim Cell As Range
Set Ws = ThisWorkbook.Sheets("Sheet1")
Set Rng = Ws.Range("A1:A5")
Set Rng = Union(Rng, Ws.Range("C1:C5"))
Flag = True
Rng.Dirty
Flag = False
Ws.Range("F1").Value = IIf(Flag, "On", "Off")
End Sub
in Sheet1 Worksheet_Calculate event
Private Sub Worksheet_Calculate()
Dim X As Integer
Dim Cell As Range
X = 1
For Each Cell In Rng.Cells
LastValArr(X, 1) = Cell.Value
LastValArr(X, 2) = Cell.Address
X = X + 1
Next
End Sub
Edit: On second thought after initial feel good of posting the Demo answer, I found it lacks User friendliness and ease of copy pasting UDF formulas while working in Excel Therefore i tried improvise it further so it could be used by users don't have access to VBA code and could work with copy paste of the UDF.
So 1st I came across a solution to store the Last Values in a temp sheet (may be Very Hidden Sheet). with apprehension that working with cell access may degrade performance of the code, I refrained from posting it and I finally restored to Dictionary Object.
This solution have added with basic advantage of Auto mapping of formula cells (by searching "=myformula" in used range of the Sheet) to enable/disable calculation. This would enable users without access to code modules to work freely with UDF.
Here reference to Microsoft scripting runtime has been added.
Code in module:
Global Flag As Boolean, Ws As Worksheet, Rng As Range, Dict As Dictionary
Public Function MyFormula() As Variant
Dim Adr As String
If Flag Then
MyFormula = GetNewValueFromAPI() 'expensive call to server
Else
Adr = Application.Caller.Address
'Debug.Print Adr
MyFormula = IIf(Dict.Exists(Adr), Dict(Adr), 0)
End If
End Function
Function GetNewValueFromAPI() As Variant
'Delay (2)
GetNewValueFromAPI = Application.WorksheetFunction.RandBetween(1, 1000)
End Function
Sub CalcA1()
Flag = True
If Not Rng Is Nothing Then Rng.Dirty
'Debug.Print "in calA1"
Flag = False
Ws.Range("F1").Value = IIf(Flag, "On", "Off")
End Sub
Sub ToggleFlag()
Flag = Not Flag
Ws.Range("F1").Value = IIf(Flag, "On", "Off")
If Flag And Not Rng Is Nothing Then Rng.Dirty
End Sub
Sub BuildRange()
Application.EnableEvents = False
Dim Cell As Range
CalcCnt = CalcCnt + 1
Set Rng = Nothing
Dict.RemoveAll
For Each Cell In Ws.UsedRange.Cells
If Left(Cell.Formula, 10) = "=myformula" Then
'Debug.Print "From Sht Calc -" & Cell.Address
If Dict.Exists(Cell.Address) = False Then
Dict.Add Cell.Address, Cell.Value
Else
Dict(Cell.Address) = Cell.Value
End If
If Rng Is Nothing Then
Set Rng = Cell
Else
Set Rng = Union(Rng, Cell)
End If
End If
Next
Application.EnableEvents = True
End Sub
In Workbook_Open
Private Sub Workbook_Open()
'Dim X As Integer
Dim Cell As Range
Set Ws = ThisWorkbook.Sheets("Sheet1")
Set Dict = New Dictionary
Flag = True
BuildRange
If Not Rng Is Nothing Then Rng.Dirty
Flag = False
Ws.Range("F1").Value = IIf(Flag, "On", "Off")
End Sub
In Sheet Calculate event
Private Sub Worksheet_Calculate()
BuildRange
End Sub
If you are using an UDF in the cell, I will like to make it like this workaround.
For demo and test, Only used a single cell A1 in "Sheet1" , instead of using any API, I used WorksheetFunction.RandomBetween May use range and array if multiple cells are used.
In "Sheet1" cell A1 used =myFormula()
in a module
Public Flag As Boolean, LastVal As Variant
Public Function MyFormula() As Variant
If Flag Then
MyFormula = GetNewValueFromAPI() 'expensive call to server
Else
MyFormula = LastVal
End If
End Function
Function GetNewValueFromAPI() As Variant
GetNewValueFromAPI = Application.WorksheetFunction.RandBetween(1, 1000)
End Function
Sub CalcA1 in Module1 would be used to recalculate A1 whenever necessary. It could be called from any events also according to actual requirement.
Sub CalcA1()
Flag = True
Worksheets("Sheet1").Range("A1").Dirty
Flag = False
End Sub
In workbook Open event the the LastVal was calculated with Flag as true and then Flag was reset to false to prevent further calling GetNewValueFromAPI
Private Sub Workbook_Open()
Flag = True
Worksheets("Sheet1").Range("A1").Dirty
LastVal = Worksheets("Sheet1").Range("A1").Value
Flag = False
End Sub
In Worksheet_Calculate event of Sheet1 the LastVal is being recorded.
Private Sub Worksheet_Calculate()
LastVal = Worksheets("Sheet1").Range("A1").Value
End Sub
Working Demo
Regret, I came across this post (A Real Good Question) late, since We had already been used something in this line in our workplace. Thanks to #Pawel Czyz for editing the post it came under Active List today only.
A normal data validation dropdown in Excel results in the selected value being put into the cell. In my case though, I am referencing another list in my sheet whose elements can change. My goal is to make those changes apply to already selected dropdown items.
Example:
Referenced list in dropdown (sheet "List"):
A
B
C
User selects A from the dropdown in sheet "Selection":
A
Now the user changes A to Y in sheet "List":
Y
B
C
The user's selection in sheet "Selection" still shows A, but it should now show Y:
A
Is this possible in any way? Can I e.g. make the dropdown result in an address to the value, instead of the value itself?
Thanks!
There unfortunately isn't any way to do this with a formula or build-in function (that I'm aware of)
Here is something simple you could apply and work with:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target(1, 1), Range("A1:A3")) Is Nothing Then
ActiveWorkbook.Sheets("Selection").Range("A1").Value = Target(1, 1)
End If
End Sub
Assuming Range("A1:A3") is the list you are refering to. Paste this under your List sheet.
Drop Down feat. Worksheet Change Event
To 'copy' your setup, in worksheet List I have created a name
Drop1 which refers to the column range containing the values. Then
I have created a Validation Drop Down in B2 in worksheet
Selection and chose the name (Drop1) as the list.
Change the constants (Const) to fit your needs.
Module1
Option Explicit
Public strListSheet As String
Public strListRange As String
Public vntList As Variant
Sub Drop(rngList As Range)
Const cDropSheet As String = "Selection"
Const cDropRange As String = "B2"
Dim rng As Range
Dim vntNew As Variant
Dim vntVal As Variant
Dim Nor As Long
Dim i As Long
Set rng = ThisWorkbook.Worksheets(cDropSheet).Range(cDropRange)
vntVal = rng
vntNew = rngList
Nor = UBound(vntList)
For i = 1 To Nor
If vntList(i, 1) = vntVal Then
If vntVal <> vntNew(i, 1) Then
rng = vntNew(i, 1)
End If
Exit For
End If
Next
vntList = vntNew
End Sub
Sub Initialize()
Const strDrop as string = "Drop1"
Dim str1 As String
Dim lngInStr As Long
' Prepare
str1 = Names(strDrop).RefersTo
lngInStr = InStr(1, str1, "!")
' Write Public Variables
strListRange = Right(str1, Len(str1) - lngInStr)
strListSheet = WorksheetFunction.Substitute(WorksheetFunction _
.Substitute(Left(str1, lngInStr - 1), "=", ""), "'", "")
vntList = Worksheets(strListSheet).Range(strListRange)
End Sub
ThisWorkbook
Option Explicit
Private Sub Workbook_Open()
Initialize
End Sub
List (Worksheet)
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
On Error GoTo ErrInit
If Target.Cells.Count = 1 Then
Dim rngList As Range
Set rngList = ThisWorkbook.Worksheets(strListSheet) _
.Range(strListRange)
If Not Intersect(Target, rngList) Is Nothing Then
Drop rngList
End If
End If
Exit Sub
ErrInit:
MsgBox "An unexpected error occurred. Error '" & Err.Number & "':" _
& Err.Description, vbCritical, "Error"
On Error GoTo 0
Initialize
End Sub
This is a basic error or lack of understanding on my part. I've searched a number of questions here and nothing seems applicable.
Here is the code
Option Explicit
Public Function ReturnedBackGroundColor(rnge As Range) As Integer
ReturnedBackGroundColor = rnge.Offset(0, 0).Interior.ColorIndex
End Function
Public Function SetBackGroundColorGreen()
ActiveCell.Offset(0, 0).Interior.ColorIndex = vbGreen
End Function
Public Function CountBackGroundColorGreen(rnge As Range) As Integer
Dim vCell As Range
CountBackGroundColorGreen = 0
For Each vCell In rnge.Cells
With vCell
If ReturnedBackGroundColor(vCell) = 14 Then
CountBackGroundColorGreen = CountBackGroundColorGreen + 1
End If
End With
Next
End Function
Public Function GetBackgroundColor() As Integer
Dim rnge As Range
GetBackgroundColor = 3
rnge = InputBox("Enter Cell to get Background color", "Get Cell Background Color")
GetBackgroundColor = ReturnedBackGroundColor(rnge)
End Function
I was adding the last function and everything else was working prior to that and am getting the error on the first statement in that function.
For the error, one of the possible fixes is to add a reference the proper library. I don't know what is the proper library to be referenced and cannot find what library the InputBox is contained. It's an activeX control but I don't see that in the tools->reference pull down. I do have microsoft forms 2.0 checked.
I've tried various set statements but I think that the only object that I've added is the inputbox.
Any suggestions?
thanks.
Use application.inputbox, add the type as range and Set the returned range object.
Option Explicit
Sub main()
Debug.Print GetBackgroundColor()
End Sub
Public Function GetBackgroundColor() As Integer
Dim rnge As Range
Set rnge = Application.InputBox(prompt:="Enter Cell to get Background color", _
Title:="Get Cell Background Color", _
Type:=8)
GetBackgroundColor = ReturnedBackGroundColor(rnge)
End Function
Public Function ReturnedBackGroundColor(rnge As Range) As Integer
ReturnedBackGroundColor = rnge.Offset(0, 0).Interior.ColorIndex
End Function
I have a list with background colors in "A" column and value in their ceil is the name of colors.
I want to do that when I select a cell with a background color this will change the value of "C1" value to the value that have in "A" column.
(this is not the my real name of the colors, I have a specific name for each colors.)
Like vlookup but with background colors and in the same ceil.
For example:
Thank you!
Put this in the code section of the worksheet :
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With Target
If dictColours.Exists(.Interior.ColorIndex) Then
Sheets("Sheet1").Range("C1").Value = dictColours(.Interior.ColorIndex)
End If
End With
End Sub
And add this to a new module, replacing the sheet reference:
Public dictColours As Scripting.Dictionary
Sub test()
Set dictColours = New Scripting.Dictionary
Dim rngTarget As Range
Set rngTarget = Sheets("Sheet1").Range("A1")
Do While rngTarget.Value <> ""
dictColours.Add rngTarget.Interior.ColorIndex, rngTarget.Value
Set rngTarget = rngTarget.Offset(1, 0)
Loop
End Sub
Think of using the conditional formatting.
elaborating on the very fine solution form Will I'd propose the following alternative code to be entirely put in the code section of the relevant worksheet
Option Explicit
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim dictColours As Scripting.Dictionary
Set dictColours = GetDictColours(Target.Parent)
With Target
If dictColours.Exists(.Interior.ColorIndex) Then
.Parent.Range("C1").Value = dictColours(.Interior.ColorIndex)
End If
End With
End Sub
Function GetDictColours(sht As Worksheet) As Scripting.Dictionary
Dim i As Long
Set GetDictColours = New Scripting.Dictionary
Do While sht.Range("A1").Offset(i) <> ""
GetDictColours.Add sht.Range("A1").Offset(i).Interior.ColorIndex, sht.Range("A1").Offset(i).Value
i = i + 1
Loop
End Function
aside from some stylistic choices (everyone has his own favorites), it should be more simple for the OP to handle, he being (as he himself stated) a total VBA beginner!