Delete named ranges used for chart series when deleting the chart - excel

Is there any way to delete named ranges used in chart series when the chart is being deleted?
I use named ranges quite extensively in my daily work, also for charting. When I create charts I often name data ranges and THEN use them for chart series.
I am looking for a way to delete USED named ranges WHEN I delete the chart. I thought about chart "delete" event, but I cannot find any info about it (does it even exist???).
The second issue is how to determine which ranges have been used for chart series? Deleting the named ranges is easy, but how to actually determine, which ranges have been used in chart series?
All help is MUCH appreciated. Apologies but I cannot provide you with any code, as I have no idea how to set things up

Try the next code please. The USED named ranges cannot be extract directly. I used a trick to extract the ranges form SeriesCollection formula. Then compare them with names RefersToRange.Address and delete the matching name. It (now) returns a boolean value in case of match (only to see it in Immediate Window), but not necessary for your purpose. The code also delete the invalid names (having their reference lost).
Edited: I made some researches and I am afraid it is not possible to create a BeforeDelete event... It is an enumeration of events able to be created for a chart object, but this one is missing. I like to believe that I found a solution for your problem, respectively:
Create a class able to enable BeforeRightClick event. Name it CChartClass and write the next code:
Option Explicit
Public WithEvents ChartEvent As Chart
Private Sub ChartEvent_BeforeRightClick(Cancel As Boolean)
Dim msAnswer As VbMsgBoxResult
msAnswer = MsgBox("Do you like to delete the active chart and its involved Named ranges?" & vbCrLf & _
" If yes, please press ""Yes"" button!", vbYesNo, "Chart deletion confirmation")
If msAnswer <> vbYes Then Exit Sub
Debug.Print ActiveChart.Name, ActiveChart.Parent.Name
testDeleteNamesAndChart (ActiveChart.Parent.Name)
End Sub
Create another class able to deal with workbook and worksheet events, name it CAppEvent and copy the next code:
Option Explicit
Public WithEvents EventApp As Excel.Application
Private Sub EventApp_SheetActivate(ByVal Sh As Object)
Set_All_Charts
End Sub
Private Sub EventApp_SheetDeactivate(ByVal Sh As Object)
Reset_All_Charts
End Sub
Private Sub EventApp_WorkbookActivate(ByVal Wb As Workbook)
Set_All_Charts
End Sub
Private Sub EventApp_WorkbookDeactivate(ByVal Wb As Workbook)
Reset_All_Charts
End Sub
Put the next code in a standard module (need to create a classes array in order to start the event for all existing sheet embedded charts):
Option Explicit
Dim clsAppEvent As New CAppEvent
Dim clsChartEvent As New CChartClass
Dim clsChartEvents() As New CChartClass
Sub InitializeAppEvents()
Set clsAppEvent.EventApp = Application
Set_All_Charts
End Sub
Sub TerminateAppEvents()
Set clsAppEvent.EventApp = Nothing
Reset_All_Charts
End Sub
Sub Set_All_Charts()
If ActiveSheet.ChartObjects.Count > 0 Then
ReDim clsChartEvents(1 To ActiveSheet.ChartObjects.Count)
Dim chtObj As ChartObject, chtnum As Long
chtnum = 1
For Each chtObj In ActiveSheet.ChartObjects
Set clsChartEvents(chtnum).ChartEvent = chtObj.Chart
chtnum = chtnum + 1
Next
End If
End Sub
Sub Reset_All_Charts()
' Disable events for all charts
Dim chtnum As Long
On Error Resume Next
Set clsChartEvent.ChartEvent = Nothing
For chtnum = 1 To UBound(clsChartEvents)
Set clsChartEvents(chtnum).ChartEvent = Nothing
Next ' chtnum
On Error GoTo 0
End Sub
Sub testDeleteNamesAndChart(strChName As String)
Dim rng As Range, cht As Chart, sFormula As String
Dim i As Long, j As Long, arrF As Variant, nRng As Range
Set cht = ActiveSheet.ChartObjects(strChName).Chart
For j = 1 To cht.SeriesCollection.Count
sFormula = cht.SeriesCollection(j).Formula: Debug.Print sFormula
arrF = Split(sFormula, ",")
For i = 0 To UBound(arrF) - 1
If i = 0 Then
Set nRng = Range(Split((Split(sFormula, ",")(i)), "(")(1))
Else
Set nRng = Range(Split(sFormula, ",")(i)) '(1)
End If
Debug.Print nRng.Address, matchName(nRng.Address)
Next i
ActiveSheet.ChartObjects(strChName).Delete
End Sub
Private Function matchName(strN As String) As Boolean
Dim Nm As Name, strTemp As String
For Each Nm In ActiveWorkbook.Names
On Error Resume Next
strTemp = Nm.RefersToRange.Address
If Err.Number <> 0 Then
Err.Clear
Nm.Delete
Else
If strN = strTemp Then
Nm.Delete
matchName = True: Exit Function
End If
End If
On Error GoTo 0
Next
End Function
Use the next events code in the ThisWorkbook module:
Option Explicit
Private Sub Workbook_Open()
InitializeAppEvents
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
TerminateAppEvents
End Sub
Please confirm that it worked as you need

Related

Run an Excel macro if cell "A500" gets visible / on screen

I'd like to get an Excel macro running as soon as cell "A500"
becomes visible on the screen when scrolling down/up the worksheet.
I remember reading somewhere about an active-x or standard control
that has an "on scrolling into view" event, so this could be done
by placing a control directly on the worksheet near the desired cell.
Finding this control currently eludes me.
A better way of course would be a cell formula, subclassing still is
a bad idea in the long run i guess :)
Sub temp_01() 'Excel Vba
'user scrolls down from cell "A1"
'when the user reaches cell "A500" show the following message:
MsgBox "Chapter 2"
End Sub
As mentioned above, with the help of the Onupdate event, (catches the mousewheel, not clicking on the scrollbars) (Change Sheetname(s) and Range(s) to yours)
In Class called ClsMonitorOnupdate:
Option Explicit
Private WithEvents objCommandBars As Office.CommandBars
Private rMonitor As Range
Private scrol As Boolean
Public Property Set Range(ByRef r As Range): Set rMonitor = r: End Property
Public Property Get Range() As Range: Set Range = rMonitor: End Property
Private Sub Class_Initialize()
Set objCommandBars = Application.CommandBars
End Sub
Private Sub Class_Terminate()
Set objCommandBars = Nothing
End Sub
Private Sub objCommandBars_OnUpdate()
Dim myrng As Range
If ActiveWorkbook.Name <> ThisWorkbook.Name Then Exit Sub
If ActiveSheet.Name <> rMonitor.Parent.Name Then Exit Sub
If TypeName(Selection) <> "Range" Then Exit Sub
If Intersect(Selection, rMonitor) Is Nothing Then Exit Sub
Set myrng = Application.Intersect(ActiveWindow.VisibleRange, ActiveSheet.Range("a500"))
If Not myrng Is Nothing And Not scrol Then scrol = True: MsgBox "chapter"
If myrng Is Nothing And scrol Then scrol = False
End Sub
In the ThisWorkbook section:
Option Explicit
Private sRanges As String
Private cMonitor As ClsMonitorOnupdate
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set cMonitor = Nothing
End Sub
Private Sub Workbook_Open()
Zetaan ActiveSheet
End Sub
Sub Zetuit()
Set cMonitor = Nothing
End Sub
Sub Zetaan(sht As Worksheet)
Select Case sht.Name
Case "Sheet1": sRanges = "A1:ZZ1000"
Case "Other Sheet": sRanges = "A1:ZZ1000"
Case Else: Exit Sub
End Select
Set cMonitor = New ClsMonitorOnupdate
Set cMonitor.Range = Sheets(sht.Name).Range(sRanges)
End Sub
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Zetaan Sh
End Sub
Private Sub Workbook_SheetDeactivate(ByVal Sh As Object)
Set cMonitor = Nothing
End Sub

Run a function in real time on Excel Macro

I need some idea to make this function update in real time. This function count the color of the cells for a work I need.
Function COUNTCOLOR(celdaOrigen As Range, rango As Range)
Application.Volatile
Dim celda As Range
For Each celda In rango
If celda.Interior.Color = celdaOrigen.Interior.Color Then
COUNTCOLOR = COUNTCOLOR + 1
End If
Next celda
End Function
I already try to run this function
Application.CalculateFullRebuild
But It didn't work in real time, I had to assign that function to a button and when I want to update the cells which count the colors I press the button, but that's not what I want. I want the cells count the colors in real time, I want they show me the number immediately I change a color. The cell that count the color has the following formula:
=COUNTCOLOR(A1;A1:A9998)
Where "A1" is a cell of the color I want the cell counts (like a sample), and the "A1:A9998" is the range where I want the formula find the color a the previous assigned sample. The cell will show a number of the cells in the range with the color of the sample.
I hop this information I provided can help you to give me a good answer :)
Thank you so much!
Perhaps, it's not the most elegant solution, but it works. The idea is to run the Sub every 5-10 seconds to make it work in real time.
Here is the code:
Sub COUNTCOLOR()
Dim RunTime
Dim COUNTCOLOR As Integer
Dim celda As Range
Dim lastRow As Variant
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
Dim rango As Range
Set rango = Range("A1:A" & lastRow)
For Each celda In rango
'Compare cell interior color with cell A1
If celda.Interior.Color = Cells(1, "A").Interior.Color Then
COUNTCOLOR = COUNTCOLOR + 1
End If
Cells(1, "C").Value = COUNTCOLOR
Next celda
'To run sub every 5 seconds
RunTime = Now + TimeValue("00:00:05")
Application.OnTime RunTime, "COUNTCOLOR"
End Sub
Insert a class module and name it ClsMonitorOnupdate
Put in the code below
Option Explicit
Private WithEvents objCommandBars As Office.CommandBars
Private rMonitor As Range
Public Property Set Range(ByRef r As Range): Set rMonitor = r: End Property
Public Property Get Range() As Range: Set Range = rMonitor: End Property
Private Sub Class_Initialize()
Set objCommandBars = Application.CommandBars
End Sub
Private Sub Class_Terminate()
Set objCommandBars = Nothing
End Sub
Private Sub objCommandBars_OnUpdate()
If ActiveWorkbook.Name <> ThisWorkbook.Name Then Exit Sub
If TypeName(Selection) <> "Range" Then Exit Sub
If Intersect(Selection, rMonitor) Is Nothing Then Exit Sub
rMonitor.Dirty 'dosomething to trigger your function
End Sub
In the ThisWorkbooksection you put:
Option Explicit
Private Const sRanges As String = "A1:A100" 'adjust to your range Rango?
Private Const sSheet As String = "YourSheetName" 'adjust to your sheetname
Private cMonitor As ClsMonitorOnupdate
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Set cMonitor = Nothing
End Sub
Private Sub Workbook_Open()
Set cMonitor = New ClsMonitorOnupdate
Set cMonitor.Range = Sheets(sSheet).Range(sRanges)
End Sub
Adjust your Sheetname and range to monitor, after running the WorkBookopen event your range(s) will be monitored and a color-change will recalculate your Countcolor function (you can leave application.volatile out of it)

get value from specific background

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!

Macro/Private Sub: Set similar filter on several sheets simultaneously

I work with sheets named; Rev00, Rev01, Rev02 etc - among other sheets in my workbook.
It would be very helpful (in order to compare the sub-summaries of different revisions) to set the exact same multiple-filter - as set in active sheet - in only all sheets beginning with "Rev".
This action should most wanted be activated by double Click in Range("A1") or somewhere like that (I dont want button on this one).
If possible next double Click in Range("A1") should reset filters.
Sub Test()
Dim ws As Worksheet, str As String
For Each ws In Worksheets
str = Left(ws.Name, 3)
If str = "Rev" Then
' set filter as in active.sheet
End If
Next ws
End Sub
... and I am stuck ....
will anyone guide me on this?
Yes it is possible. :) Here is a basic sample on how it should work.
Sub Test()
Dim ws As Worksheet, str As String
For Each ws In Worksheets
str = Left(ws.Name, 3)
If UCase(str) = "REV" Then
With ws
'~~> Remove any filters
.AutoFilterMode = False
With <YOUR RANGE>
.AutoFilter Field:=<RELEVANT FIELD>, _
Criteria1:=<YOUR CRITERIA>
'
'~~> Rest of the code
'
End With
'~~> Remove any filters
'.AutoFilterMode = False
End With
End If
Next ws
End Sub
Here you can see Autofilter in action :)
To call the above code by clicking Range A1, you can use the Worksheet_BeforeDoubleClick event.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("A1")) Is Nothing Then
'
'~~> Your code goes here
'
Cancel = True
End If
End Sub
Regarding your query about making Range A1 respond as an ON/OFF switch, you can use a boolean variable s shown HERE

How to assign a name to an Excel cell using VBA?

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

Resources