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

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

Related

Delete named ranges used for chart series when deleting the chart

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

VBA Excel: Get the clicked cell´s adress on another workbook

I have an excel file A with a macro and I have to retrive a cell´s adress in another excel file B by the user´s click on it.
The macro looks like this.
In the Class:
Public WithEvents appevent As Application
Private Sub appevent_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
ClickedCell = ActiveCell.Address
End Sub
In the Module
Sub ClickedCellSub()
Dim WbA As Variant, WbB As Variant
WbA = ThisWorkbook.Name
WbB = "B.xlsx"
MsgBox "Please double click on the Assembly SS 00 you want to compare"
Set myobject.appevent = Application
Workbooks(WbB).Sheets(1).Activate
Set myobject.appevent = Nothing
MsgBox ClickedCell
Workbooks(WbA).Activate
End Sub
The problem is, the macro doesn´t wait for the event DoubleClick on the other excel sheet and goes to the end.
How can I stop the macro until the event happens?
Many thanks in advance!
I would use event sinking, but not sure how you have approached it, but this is how i'd use.
In a class use the following :
Private WithEvents wb As Excel.Workbook
Private rng As Excel.Range
Public Event evtCellClicked(rngClicked As Excel.Range)
Public Event evtCellDoubleClicked(rngDoubleCliecked As Excel.Range)
Public Sub init(wbInput As Excel.Workbook)
Set wb = wbInput
End Sub
Public Property Get CellClicked() As Excel.Range
CellClicked = rng
End Property
Private Sub wb_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Set rng = Target
RaiseEvent evtCellClicked(Target)
End Sub
Private Sub wb_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Set rng = Target
RaiseEvent evtCellClicked(Target)
End Sub
I changed the code. In the module:
enter Option Explicit
Private mobjApplication As clsApplication
Global ClickedCell As String
Sub Vergleichen()
Dim StruktBer As Variant
StruktBer = Application.GetOpenFilename(, , "Strukturbericht öffnen") '####Name der Datei aus der Strukturberich
Set mobjApplication = New clsApplication
Workbooks.Open StruktBer
MsgBox "Bitte die Sachnummer der Strukturstufe '00' anklicken die man vergleichen möchte"
End Sub
Sub GOFURTHER
In the Class:
Option Explicit
Private WithEvents mobjApplication As Application
Private Sub Class_Initialize()
Set mobjApplication = Application
End Sub
Private Sub mobjApplication_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
ClickedCell = Target.Address
Set mobjApplication = Nothing
Call GOFURTHER
End Sub
The macro stops until the user clicks on the other excel table. Is there any way not to exit the first sub and to remain in the first one?
Why not simply using an InputBox ?
https://learn.microsoft.com/en-us/office/vba/api/excel.application.inputbox
In your prompt you ask the user to select a range in the appropriate document, and that's it.

How do I combine separate macros for the same event in the 'ThisWorkbook' module?

I have a macro in the 'ThisWorkbook' module set to run 'BeforeSave'. I have two other macros that I also need to run 'BeforeSave'. Can I add additional macros to this module?
I have created my macros in the 'standard' module section, and they work with the selection of the 'Run' button. I have attempted to add the 'Macro/Module names' to the bottom of my 'BeforeSave' macro which has done nothing but give me errors.
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call HideRows
Call DivAdminApproval
Call ProjNumbrReq
End Sub
Public Sub HideRows()
'When a row begins with X in Travel Expense Codes worksheet, hide the row
Const beginRow As Long = 3
Const endRow As Long = 38
Const chkCol As Long = 14
Dim rowCnt As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Travel Expense Codes")
For rowCnt = endRow To beginRow Step -1
With ws.Cells(rowCnt, chkCol)
.EntireRow.Hidden = (.Value = "X")
End With
Next rowCnt
End Sub
Public Sub ProjNumbrReq()
'Call ProjNumbrReq
With Worksheets("Travel Expense Voucher")
For Each myCell In .Range("U15:U45")
If myCell.Value > 0 And .Cells(myCell.row, "N") = "" Then
MsgBox "Project Number must be provided on each line where reimbursement is being claimed.", vbCritical, "Important:"
Cancel = True
Exit Sub
End If
Next myCell
End Sub
Public Sub DivAdminApproval()
'Call DivAdminApproval
With Worksheets("Travel Expense Voucher")
If Worksheets("Travel Expense Voucher").Cells("F5") = 2 Then
For Each myCell In .Range("O15:O45")
If myCell.Value = 0.58 Then
MsgBox "You have selected reimbursement at the 'HIGH' mileage rate ($.58/mile). To receive reimbursement at this rate, Division Administrator Approval is Required.", vbCritical, "Important:"
Exit Sub
End If
Next myCell
End Sub
The ProjNumbrReq and DivAdminApproval macros have been listed before End Sub, hoping that would call them to work. However, they are not running.
something along these lines, if your macros are not in the 'ThisWorkbook' module then make sure they are defined public (instead of private):
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Call sMacro1
Call sMacro2
Call sMacro3
End Sub
Private Sub sMacro1()
'do something
End Sub
Private Sub sMacro2()
'do something
End Sub
Private Sub sMacro3()
'do something
End Sub

Run this Worksheet_Calculate when opening workbook without running my Macro

Right now my process is working correctly, with the help of this community, however, I need this Worksheet_Calculate to NOT execute the Macro (MacroRuns for example) when the workbook opens, but I still need it to function the same way it is currently, after the workbook is opened.
Thank you so much for your help in advance!
The Code I Am Using:
in ThisWorkbook
Option Explicit
Private Sub Workbook_Open()
TargetStart
End Sub
in the target sheet's code window
Option Explicit
Private Sub Worksheet_Calculate()
Application.EnableEvents = False
TargetCalc Me
Application.EnableEvents = True
End Sub
in Module 1
Option Explicit
Public TargetValue As Variant
Private Const cTarget As String = "C3"
Sub TargetCalc(ws as Worksheet)
If ws.Range(cTarget) <> TargetValue Then
'this is where I would like the code to say something like, "if workbook just opened, exit -- otherwise continue. If this is even possible.
Call MacroRuns
TargetValue = ws.Range(cTarget).Value
End If
End Sub
Sub TargetStart()
TargetValue = Sheet1.Range(cTarget).Value
End Sub
Sub MacroRuns()
Call UpdateMsgBox
End Sub
I think that this can solve your problem:
In ThisWorkbook:
Private Sub Workbook_Open()
Worksheets("NameHere").Range("A1") = True
End Sub
In the target sheet's code window:
Private Sub Worksheet_Calculate()
If Worksheets("NameHere").Range("A1") Then MacroRuns
Worksheets("NameHere").Range("A1") = False
End Sub
Please try this arrangement.
Public StartUp As Boolean
Private Sub Workbook_Open()
StartUp = True
TargetStart
End Sub
Sub TargetCalc(ws As Worksheet)
If ws.Range(cTarget) <> TargetValue Then
If Not StartUp Then MacroRuns
StartUp = False
TargetValue = ws.Range(cTarget).Value
End If
End Sub
or, perhaps you prefer it to be like this.
Sub TargetCalc(ws As Worksheet)
If ws.Range(cTarget) <> TargetValue Then
If Not StartUp Then
MacroRuns
TargetValue = ws.Range(cTarget).Value
End If
StartUp = False
End If
End Sub

Right-click withevents works on source .xlsm but not on .xlam addin

I've made a couple of macros that run through right click menu button based on the cell value. Typically, if I right click on cell with value 'XYZ', the menu button shows as 'Run macro for XYZ' and then does a bunch of operations: show a couple of user forms, run an SQL query, show and format result data.
On the original .xlsm file, on 'Thisworkbook' I have the following code:
Public WithEvents mxlApp As Application
Public WithEvents mxlSh As Worksheet
Private Sub mxlApp_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As
Boolean)
... (do stuff here) ...
End Sub
...
Private Sub Workbook_Open()
Call AutoExec
End Sub
...
On a separate module, I have the following function used to set my event handler
Public Sub AutoExec()
Set mxlApp = Application
Set ColectionOfMxlEventHandlers = New Collection
ColectionOfMxlEventHandlers.Add mxlApp
Debug.Print ThisWorkbook.Name & " Initialized"
End Sub
The problem: on the original .xlsm file, the code works fine: every time I right-click on a cell which meets certain criteria, I get the 'Run macro for XYZ' and all is fine.
Once I save the file as .xlam and load it as addin, the code won't work.
I have been looking everywhere on the internet and here and couldn't figure out how to resolve this issue.
EDIT:
After modifying the code as kindly suggested by creamyegg, this is what I have:
In class module clsAppEvents:
Private WithEvents mxlApp As Excel.Application
Private Sub Class_Initialize()
Set mxlApp = Excel.Application
End Sub
Private Sub mxlApp_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
Dim cBut As CommandBarButton
On Error Resume Next
Call CleanMenu
If Len(Target.Value) = 8 Then
MyId = Target.Value
With Application
Set cBut = .CommandBars("Cell").Controls.Add(Temporary:=True)
End With
With cBut
.Caption = "Run SQL Query for " & MyId
.Style = msoButtonCaption
.FaceId = 2554
.OnAction = "CallGenericQuery"
End With
End If
With Application
Set cBut = .CommandBars("Cell").Controls.Add(Temporary:=True)
End With
With cBut
.Caption = "Columns_Select"
.Style = msoButtonCaption
.FaceId = 255
.OnAction = "CallShowHide"
End With
On Error GoTo 0
End Sub
in Thisworkbook class I have
Public m_objMe As clsAppEvents
Private Sub Workbook_Open()
Set m_objMe = New clsAppEvents
Debug.Print ThisWorkbook.Name & " Initialized"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
On Error Resume Next
Call CleanMenu
On Error GoTo 0
Set m_objMe = Nothing
End Sub
Private Sub Workbook_Deactivate()
Call CleanMenu
End Sub
MyId is defined as a public string in the main module containing the CallShowHide and callGenericQuery subs
The issue sounds like your WithEvents is still in your ThisWorkbook Class? What you need to do is create a new class and then instantiate an instance of this on the Workbook_Open() event of your add-in. For example:
New Class (clsAppEvents):
Private WithEvents mxlApp As Excel.Application
Private Sub Class_Initialize()
Set mxlApp = Excel.Application
End Sub
Private Sub mxlApp_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
...
End Sub
Add-in ThisWorkbook Class:
Private m_objMe As clsAppEvents
Private Sub Workbook_Open()
Set m_objMe = New clsAppEvents
End Sub
Private Sub WorkbookBeforeClose(Cancel As Boolean)
Set m_objMe = Nothing
End Sub

Resources