I'm trying to finish this off so that I can click on cells ws2(D11) and ws3(C12) and show a box containing the ClientNumber. I just can't get my head around how that works, as I've tried to adapt some solutions to my code, but have been unsuccessful, and don't know quite why.
Public ClientNumber As String
Sub Booker()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set ws = Sheets("ClientEnd")
Set ws2 = Sheets("Booking End")
Set ws3 = Sheets("Training End")
Dim ClientName As String
ClientName = InputBox("Please enter your name")
ClientNumber = InputBox("Please enter a contact number")
ws2.Range("D11") = ClientName
ws3.Range("C12") = ClientName
ws2.Range("O11:R11").Style = "Good"
ws3.Range("H12:K12").Style = "Good"
ws3.Range("I12").Style = "Normal"
Call NumberBox
End Sub
Sub NumberBox()
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Set ws = Sheets("ClientEnd")
Set ws2 = Sheets("Booking End")
Set ws3 = Sheets("Training End")
If Target.Address = ws2.Range("$D$11") Then MsgBox ClientNumber
If Target.Address = ws3.Range("$C$12") Then MsgBox ClientNumber
End Sub
I was hoping to have the ClientNumber pop up in a message when I clicked on the given cells in each sheet, which do update to the ClientName successfully, but nothing happens. No errors, nothing.
You can use the event Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean).
In ws3 put
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("C12")) Is Nothing Then 'range than u want to capture
Call NumberBox 'your code
End If
End Sub
Do the same for ws2
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Not Intersect(Target, Range("D11")) Is Nothing Then 'range than u want to capture
Call NumberBox 'your code
End If
End Sub
You have to double click on the cell to run the event
You could try adding the SelectionChange event to the worksheets. On Worksheet 2 and 3 Add the code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Address = "&D&11" Then 'Change the "&D&11" to "&C&12" for worksheet 3
Call NumberBox ' You could also add Target as a paramater
End If
End Sub
Related
So I have a dynamically created worksheet (generated by clicking a command button on a separate sheet) and I am trying to get a Worksheet_Change event to fire only on a specific range in that worksheet. My code is as follows:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim sh As Worksheet
Set sh = ThisWorkbook.ActiveSheet
If Not Intersect(Target, Range("A1:K10")) Is Nothing Then
If sh.Name Like "*SP Temp*" Then
Dim i As Variant, countOfS As Integer
countOfS = 0
For Each i In sh.Range("A1:K10")
If i.Value = "S" Then
countOfS = countOfS + 1
End If
Next i
sh.Range("D12").Value = countOfS
sh.Range("D13").Value = SCount - countOfS
' NOTE: SCount is a global variable set in another Sub
End If
End If
End Sub
The intent is to keep a running count of the number of "S" characters entered into cells in the range A1:K10. I have tried adding in Debug.Print statements after the If Not Intersect... statement, but it doesn't seem to fire, despite the values in the target range being altered. What am I doing wrong?
A Workbook SheetChange: Count and Write
ThisWorkbook Module
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
' Invalidate.
If Not Sh.Name Like "*SP Temp*" Then Exit Sub ' wrong worksheet
Dim rg As Range: Set rg = Sh.Range("A1:K10")
If Intersect(rg, Target) Is Nothing Then Exit Sub ' no intersection
' Count.
Dim CountOfS As Long: CountOfS = Application.CountIf(rg, "s")
' Write
' Disable events to not re-trigger the event while writing
' since the same worksheet is being written to.
Application.EnableEvents = False
Sh.Range("D12").Value = CountOfS
Sh.Range("D13").Value = SCount - CountOfS
Application.EnableEvents = True
End Sub
Sheet1
Private Sub Worksheet_change(ByVal Target As Range)
If Not Intersect(Target, Range("B93")) Is Nothing Then
If Target = Range("B93") Then
Sheets("Sheet2").Range("A1").Value = Target.Value
End If
End If
End Sub
Sheet2
Private Sub Worksheet_change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
If Target = Range("A1") Then
If Sheets("Sheet1").Range("B93").Value <> Target.Value Then
Sheets("Sheet1").Range("B93").Value = Target.Value
End If
End If
End If
End Sub
The code works for only single cell on B93 and A1.
I tried setting the range to Range("B93:N122") on sheet1 and Range("A1:M22") on sheet 2 to mirror the ranges when changes happened but I get the error 13 mismatch.
Goal: I want to mirror the changes (two way) on range(A1:M22) sheet 1 to sheet 2 vice versa. What line of code am i missing?
Mirror Ranges
Values changed in cells of one worksheet will also change to the same values in the same cells of the other worksheet and vice versa.
Standard Module e.g. Module1
Option Explicit
Sub MirrorWorksheets( _
ByVal Target As Range, _
ByVal RangeAddress As String, _
ByVal WorksheetName As String)
Dim sws As Worksheet: Set sws = Target.Worksheet
Dim irg As Range: Set irg = Intersect(sws.Range(RangeAddress), Target)
If irg Is Nothing Then Exit Sub
Dim dws As Worksheet: Set dws = sws.Parent.Worksheets(WorksheetName)
Application.EnableEvents = False
Dim iarg As Range
For Each iarg In irg.Areas
dws.Range(iarg.Address).Value = iarg.Value
Next iarg
Application.EnableEvents = True
End Sub
Sheet1 Module
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
MirrorWorksheets Target, "A1:M22,B93:N122", "Sheet2"
End Sub
Sheet2 Module
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
MirrorWorksheets Target, "A1:M22,B93:N122", "Sheet1"
End Sub
When I double-click on a cell in one table, how can I simulate a hyperlink to a corresponding cell in another table? I am getting a type mismatch error with sCellAddress.
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Set tb = ActiveSheet.ListObjects("Table1")
If Not Intersect(Target, tb.ListColumns("Site").DataBodyRange) Is Nothing Then
Cancel = True
Dim sCellAddress As String
sCellAddress = [CELL("address", INDEX(Sites[Base], MATCH([#Site], Sites[Site], 0)))]
Application.Goto ActiveSheet.Range(sCellAddress)
End If
End Sub
Separately, how can I specify multiple ranges for RangeExclude?
Private Sub Workbook_SheetBeforeDoubleClick(ByVal sH As Object, ByVal Target As Range, Cancel As Boolean)
Dim ShExclude As Worksheet, RangeExclude As Range
Set ShExclude = ThisWorkbook.Worksheets("Sheet1")
Set RangeExclude = ShExclude.ListObjects("Table1").ListColumns("Sites").DataBodyRange
End Sub
Here's how I would do it
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim loFrom As ListObject
Dim loTo As ListObject
Dim rFound As Range
Set loFrom = Me.ListObjects("tblOne")
Set loTo = Me.ListObjects("tblTwo")
If Not Intersect(loFrom.ListColumns("Site").DataBodyRange, Target) Is Nothing Then
Set rFound = loTo.ListColumns("Site").DataBodyRange.Find(Target.Value, , xlValues, xlWhole)
If Not rFound Is Nothing Then
rFound.Select
End If
End If
End Sub
In the ListColumn that will have the value, do a Find to see if it's in there. If it is, select it.
I'm looking for a way to write into another sheet in excel, every time someone either protects or unprotects the sheet in my Workbook. I want it to log whether it was protected or unprotected and the time beside it. Thanks!
Right now I have the following code for protecting or unprotecting the sheet with a more user friendly button:
If ActiveWorkbook.Sheets("Calendar").ProtectContents = True Then
ActiveSheet.Unprotect
MsgBox "Sheet unprotected"
Exit Sub
End If
ActiveSheet.Protect ("password")
MsgBox "Calendar has been protected"
Excel VBA does not have an event that can detect if a sheet is being protected/unprotected.
Don't shoot the messenger.
A google would have landed you here: https://www.ozgrid.com/forum/index.php?thread/43816-unprotect-worksheet-event/, the author even gives you a sample:
https://www.ozgrid.com/forum/core/index.php?attachment/1082834-52719-xls/
This is not 100% fool proof as the eventhandler can not tell when a user Cancels the protect/unprotect dialog.
This workbook
Option Explicit
Private Sub Workbook_BeforeClose(Cancel As Boolean)
StartEventListiner False
End Sub
Private Sub Workbook_Open()
StartEventListiner True
End Sub
Module
Option Explicit
Public g_clsEvnt As CProtectEvt
Public Sub StartEventListiner(Action As Boolean)
If Action Then
Set g_clsEvnt = New CProtectEvt
Else
Set g_clsEvnt = Nothing
End If
End Sub
Class
Option Explicit
Public WithEvents cbbProtect As CommandBarButton
Private Sub m_ProtectControls(State As Boolean)
Dim objX As OLEObject
On Error Resume Next
For Each objX In ActiveSheet.OLEObjects
objX.Object.Enabled = State
Next
End Sub
Private Sub cbbProtect_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
m_ProtectControls (InStr(1, Ctrl.Caption, "Un&protect", vbTextCompare) > 0)
End Sub
Private Sub Class_Initialize()
On Error Resume Next
' hook into Tools > Protection > Protect Sheet event
Set cbbProtect = Application.CommandBars.FindControl(msoControlButton, ID:=893)
End Sub
Toggle and Log Worksheet Protection
The code only logs the protection when using the button (which has toggleWorksheetProtection_Click assigned to it) or when running toggleWorksheetProtection_Click from VBE.
Copy the complete code into a standard module (e.g. Module11).
Adjust the values of the five constants.
ThisWorkbook refers to the workbook containing this code.
Additionally adjust the date format in writeLogRow.
The Code
Option Explicit
Sub toggleWorksheetProtection_Click()
' Constants
Const srcName As String = "Calendar"
Const tgtName As String = "Log"
Const tgtCol As Variant = 1
Const msgProtect As String = "Sheet protected."
Const msgUnProtect As String = "Sheet unprotected."
' Workbook
Dim wb As Workbook: Set wb = ThisWorkbook
' Other Variables
Dim src As Worksheet: Set src = wb.Worksheets(srcName)
Dim tgt As Worksheet: Set tgt = wb.Worksheets(tgtName)
Dim msg As String
' Protection
If src.ProtectContents Then
src.Unprotect: msg = msgUnProtect
Else
src.Protect: msg = msgProtect
End If
' Log
Dim cel As Range
Set cel = getEmptyCell(tgt, tgtCol)
writeLogRow cel, msg
End Sub
Function getEmptyCell(Sheet As Worksheet, ByVal writeColumn As Variant)
Dim cel As Range
Set cel = Sheet.Columns(writeColumn).Find("*", , xlValues, , , xlPrevious)
If Not cel Is Nothing Then
Set cel = cel.Offset(1)
Else
Set cel = Sheet.Cells(1, writeColumn)
End If
Set getEmptyCell = cel
End Function
Sub writeLogRow(logRange As Range, ByVal logMessage As String)
Dim logDate As Date: logDate = Now
logRange.Value = logDate
logRange.NumberFormat = "mm/dd/yyyy hh:mm:ss (ddd)"
logRange.Offset(, 1).Value = logMessage
End Sub
Hi everyone i made a button on excel using VBA modules,The code works on the active sheet but what im looking for is to be applied to more sheets, not just the active sheet where the button is placed.
Sub Botón1_Haga_clic_en()
Call Worksheet_Calculate
End Sub
'apply cells colors from single-cell formula dependencies/links
Private Sub Worksheet_Calculate()
Dim Cel As Range
Dim RefCel As Range
On Error Resume Next
For Each Cel In ActiveSheet.UsedRange
If Cel.HasFormula Then
Set RefCel = Evaluate(Mid(Cel.Formula, 2))
Cel.Interior.Color = RefCel.Interior.Color
End If
Next Cel
End Sub
Try the code below :
Option Explicit
Sub Botón1_Haga_clic_en()
Dim wsName As String
Dim ws As Worksheet
wsName = ActiveSheet.Name
For Each ws In ThisWorkbook.Worksheets
If Not ws.Name Like wsName Then '<-- is worksheet's name doesn't equal the ActiveSheet's
ApplyCellColors ws ' <-- call you Sub, with the worksheet object
End If
Next ws
End Sub
'=======================================================================
'apply cells colors from single-cell formula dependencies/links
Private Sub ApplyCellColors(ws As Worksheet)
Dim Cel As Range
Dim RefCel As Range
On Error Resume Next
For Each Cel In ws.UsedRange
If Cel.HasFormula Then
Set RefCel = Evaluate(Mid(Cel.Formula, 2))
Cel.Interior.Color = RefCel.Interior.Color
End If
Next Cel
End Sub
Your problem can be translated to something like How to loop over all sheets and ignore one of them?
This is a good way to do it:
Option Explicit
Option Private Module
Public Sub TestMe()
Dim wks As Worksheet
For Each wks In ThisWorkbook.Worksheets
If wks.name = "main" Then
Debug.Print "Do nothing here, this is the active sheet's name"
Else
Debug.Print wks.name
End If
Next wks
End Sub
Pretty sure, that you should be able to fit it in your code.