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

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.

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

Excel VBA application event triggered twice

I am trying to change active printer according to worksheet name when click on Quick Print button, however, the App_WorkbookBeforePrint event is triggered twice. Tried App_WorkbookBeforeClose also triggered twice. I have already changed the Error Trapping to Break on All Error, but it seems like no errors have occurred.
ThisWorkbook:
Private XLApp As CExcelEvents
Private Sub Workbook_Open()
Set XLApp = New CExcelEvents
End Sub
Class Modules:
Option Explicit
Private WithEvents App As Application
Private Sub Class_Initialize()
Set App = Application
End Sub
Private Sub App_WorkbookBeforePrint(ByVal Wb As Workbook, Cancel As Boolean)
MsgBox Wb.FullName
assignPrinter
End Sub
Module:
Const printer1 As String = "Bullzip PDF Printer on Ne10:"
Const printer2 As String = "EPSONF7E8B5 (L565 Series) on Ne07:"
Public Sub assignPrinter()
Dim ws As Worksheet
Dim wsn As String
Set ws = ActiveWorkbook.ActiveSheet
wsn = ws.Name
Select Case wsn
Case "FGWIP"
Application.ActivePrinter = printer1
ws.PrintOut
Exit Sub
Case "Rework"
Application.ActivePrinter = printer2
ws.PrintOut
Exit Sub
Case Else
MsgBox "Else case."
Exit Sub
End Select
End Sub
Update:
Use App_SheetActivate instead of App_WorkbookBeforePrint to change active printer and remove ws.Printout as mentioned by Matley
I re-created your modules and the only error I received was in the code Debug.Print assignPrinter in which I replaced with assignPrinter.
The rest of the codes works fine. App_WorkbookBeforePrint did not trigger twice. You can set a breakpoint in App_WorkbookBeforePrint then look into Stack to see which triggers App_WorkbookBeforePrint for the second time.

How to have a VBA cancel the script?

How can I have the VBA code cancel if the cancel button is pressed. I have...
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim ws As Worksheet
Set ws = Sheets("EDITS")
Dim tbl As ListObject
Set tbl = ws.ListObjects("Table1")
Dim newrow As ListRow
Set newrow = tbl.ListRows.Add
SavePrompt.Show
With newrow
.Range(1) = Now
.Range(2) = SavePrompt.TextBox1.Text
End With
End Sub
and added...
Private Sub CommandButton1_Click()
SavePrompt.Hide
End Sub
And,
Private Sub CommandButton2_Click()
Cancel = True
End Sub
to the Workbook Project Macro section.
But for some reason I'm not sure how to get the code to Cancel since the user realizes they don't want to save the changes they for some reason made to the Workbook. This SavePrompt help diagnose what was changed and when.
I thin your meaning is when user press cancel button , you want to clean list of row.If so just make like the following simple code.
Private Sub ListObject_Delete()
Dim List1 As Microsoft.Office.Tools.Excel.ListObject = _
Me.Controls.AddListObject(Me.Range("A1", "D4"), "List1")
If DialogResult.Yes = MessageBox.Show("Delete the ListObject?", _
"Test", MessageBoxButtons.YesNo) Then
List1.Delete()
End If
End Sub

How to call macro after Refresh or Refresh All button pressed?

Ultimately, I would like to run a macro after anyone refreshes the workbook, specifically using the Refresh button under the Data tab in Excel.
For the time being, I would be satisfied just getting the BeforeRefresh or AfterRefresh QueryTable events to fire upon pressing the Refresh button.
In addition to the documentation on the Microsoft Dev Center website, the relevant posts I have read include:
Excel VBA - QueryTable AfterRefresh function not being called after Refresh completes
VBA For Excel AfterRefresh Event
There are other posts but I lack the reputation to post them.
Here is what I have:
Under Class Modules (qtclass)
Option Explicit
Private WithEvents qt As Excel.QueryTable
Private Sub qt_AfterRefresh(ByVal Success As Boolean)
MsgBox "qt_AfterRefresh called sucessfully."
If Success = True Then
Call Module2.SlicePivTbl
MsgBox "If called succesfully."
End If
End Sub
Private Sub qt_BeforeRefresh(Cancel As Boolean)
MsgBox "qt_BeforeRefresh called."
End Sub
Under the ThisWorkbook module
Private Sub Workbook_Open()
Dim qtevent As qtclass
Dim qt As QueryTable
Set qt = ThisWorkbook.Worksheets("Data-Fund").ListObjects(1).QueryTable
Set qtevent = New qtclass
End Sub
I have tried variations of the second code block under specific worksheets as well, but have yet to find anything that works. Do I need to somehow dim the QueryTable in question in the Worksheet module?
You haven't actually connected the querytable to the class instance.
Revised qtclass
Option Explicit
Private WithEvents qt As Excel.QueryTable
Public Property Set HookedTable(q As Excel.QueryTable)
Set qt = q
End Property
Private Sub qt_AfterRefresh(ByVal Success As Boolean)
MsgBox "qt_AfterRefresh called sucessfully."
If Success = True Then
Call Module2.SlicePivTbl
MsgBox "If called succesfully."
End If
End Sub
Private Sub qt_BeforeRefresh(Cancel As Boolean)
MsgBox "qt_BeforeRefresh called."
End Sub
New ThisWorkbook code:
Dim qtevent As qtclass
Private Sub Workbook_Open()
Set qtevent = New qtclass
Set qtevent.HookedTable = ThisWorkbook.Worksheets("Data-Fund").ListObjects(1).QueryTable
End Sub
Note that this is quite closely coupled. It would be more re-usable if you were to raise events in the class and declare your qtevent variable WithEvents.
Source: https://www.excelandaccess.com/create-beforeafter-query-update-events/
Class:
Note: Class Name = clsQuery
Option Explicit
Public WithEvents MyQuery As QueryTable
Private Sub MyQuery_AfterRefresh(ByVal Success As Boolean)
If Success Then
Debug.Print "After ReFresh"
End If
End Sub
Private Sub MyQuery_BeforeRefresh(Cancel As Boolean)
Debug.Print "Before ReFresh"
End Sub
Module:
Option Explicit
Dim colQueries As New Collection
Sub InitializeQueries()
Dim clsQ As clsQuery
Dim WS As Worksheet
Dim QT As QueryTable
For Each WS In ThisWorkbook.Worksheets
For Each QT In WS.QueryTables
Set clsQ = New clsQuery
Set clsQ.MyQuery = QT
colQueries.Add clsQ
Next QT
Next WS
End Sub
ThisWorkbook.Event:
Private Sub Workbook_Open()
Call InitializeQueries
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