VBA/Excel/Access/Word/Excel/Worksheet Event

Activating Only the Used Range

 
Private Sub Worksheet_Activate( )
      Me.ScrollArea = Range(Me.UsedRange, Me.UsedRange(2,2)).Address
End Sub

BeforeDoubleClick event

 
Private Sub Worksheet_BeforeDoubleClick _
    (ByVal Target As Excel.Range, Cancel As Boolean)
    Target.Font.Bold = Not Target.Font.Bold
    Cancel = True
End Sub

BeforeRightClick event

 
Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
    If IsNumeric(Target) And Not IsEmpty(Target) Then
        Application.Dialogs(xlDialogFormatNumber).Show
        Cancel = True
    End If
End Sub

Cancel a change in Worksheet Selection Change event

 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
  Dim Forbidden As Range
  
  Set Forbidden = Union(Range("B10:F20"), Range("H10:L20"))
  If Intersect(Target, Forbidden) Is Nothing Then Exit Sub
  Range("A1").Select
  MsgBox "You can"t select cells in " & Forbidden.Address, vbCritical
End Sub

changes a cell"s interior color to red when it is double-clicked:

 
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
    Cancel As Boolean)
    Dim myColor As Integer
    Target.Interior.ColorIndex = 3
End Sub

Change the range color in selection change event

 
         Sub Worksheet_SelectionChange(ByVal Target As Range)
             Rows.Interior.ColorIndex = xlColorIndexNone
             Target.EntireColumn.Interior.ColorIndex = 36
             Target.EntireRow.Interior.ColorIndex = 36
         End Sub

checks each changed cell and displays a message box if the cell is within the desired range.

 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Set VRange = Range("InputRange")
    For Each cell In Target
        If Union(cell, VRange).Address = VRange.Address Then
           Msgbox "The changed cell is in the input range."
        End if
    Next cell
End Sub

Create a function for Excel: Is a cell formula cell

 
     Function IsFormula(Check_Cell As Range)
      IsFormula = Check_Cell.HasFormula
     End Function
=IsFormula(A1)

Creating a Database Form From an Excel Worksheet in worksheet activate event

 
Private Sub Worksheet_Activate()
    Dim dbNorthwind As DAO.Database
    Dim rsCategories As DAO.Recordset
    Dim dbpath As String
    dbpath = CurrentPath & "\mydb.mdb"
    Set dbNorthwind = OpenDatabase(dbpath)
    Set rsCategories = dbNorthwind.OpenRecordset( _
        "Categories", dbOpenTable)
    With rsCategories
        If Not .BOF Then .MoveFirst
        Cells(3, 3).Value = .Fields(1).Value    "Name
        Cells(5, 3).Value = .Fields(2).Value    "Description
    End With
End Sub

disable the events and then reenable them at the end of the procedure:

 
Private Sub Worksheet_Change(ByVal Target As Range)
    Application.EnableEvents = False
    Range("A1").Value = Target.Value
    Application.EnableEvents = True
End Sub

Enable Events

 
     Private Sub Worksheet_Change(ByVal Target As Range)
           Application.EnableEvents = False
           Range("A1").Value = 100
           Application.EnableEvents = True
     End Sub

event procedure runs every time the worksheet recalculates

 
     Private Sub Worksheet_Calculate()
           Dim dProfit As Double
           dProfit = Me.Range("A1").Value
           If dProfit > 600 Then
           MsgBox "Profit has risen to " & Format(dProfit, "#,##0.0"), vbExclamation
           ElseIf dProfit < 500 Then
           MsgBox "Profit has fallen to " & Format(dProfit, "#,##0.0"), vbCritical
           End If
     End Sub

Examples of Activation Events

 
Private Sub Worksheet_Activate()
    MsgBox "You just activated " & ActiveSheet.Name
End Sub

Example that activates cell A1 whenever the sheet is activated:

 
Private Sub Worksheet_Activate()
    Range("A1").Activate
End Sub
Worksheet Deactivate event
    Private Sub Worksheet_Deactivate()
    MsgBox "You must stay on Sheet1"
    Sheets("Sheet1").Activate
End Sub

If you want the same data to appear on other sheets but not in the same cell addresses

 
Private Sub worksheet_Change(ByVal Target As Range)
      If Not Intersect(Range("MyRange"), Target) Is Nothing Then
      With Range("MyRange")
      .Copy Destination:=Sheets("Sheet3").Range("A1")
      .Copy Destination:=Sheets("Sheet1").Range("D10")
      End With
      End If
End Sub

makes use of conditional formatting and overwrites any existing conditional formatting on the sheet.

 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim iColor As Integer
    On Error Resume Next
    iColor = Target.Interior.ColorIndex
    If iColor < 0 Then
        iColor = 36
    Else
        iColor = iColor + 1
    End If
    If iColor = Target.Font.ColorIndex Then iColor = iColor + 1
    Cells.FormatConditions.Delete
    With Range("A" & Target.Row, Target.Address)
        .FormatConditions.Add Type:=2, Formula1:="TRUE"
        .FormatConditions(1).Interior.ColorIndex = iColor
    End With
    With Range(Target.Offset(1 - Target.Row, 0).Address & ":" & _
        Target.Offset(-1, 0).Address)
        .FormatConditions.Add Type:=2, Formula1:="TRUE"
        .FormatConditions(1).Interior.ColorIndex = iColor
    End With
End Sub

Monitoring a specific range for changes

 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim VRange As Range
    Set VRange = Range("InputRange")
    If Union(Target, VRange).Address = VRange.Address Then
       Msgbox "The changed cell is in the input range."
    End if
End Sub

Preventing data validation from being destroyed

 
          
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim VT As Long
    On Error Resume Next
    VT = Range("A1").Validation.Type
    If Err.Number <> 0 Then
        Application.Undo
        MsgBox "canceled."
    End If
End Sub

SelectionChange event executes whenever the user makes a new selection on the worksheet.

 
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
    Cells.Interior.ColorIndex = xlNone
    With ActiveCell
        .EntireRow.Interior.ColorIndex = 36
        .EntireColumn.Interior.ColorIndex = 36
    End With
End Sub

Some Worksheet event are executed before the associated event occurs and have a Cancel parameter that is passed by reference.

 
     Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, _
                                               Cancel As Boolean)
           Cancel = True
     End Sub

The Change event

 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Address = "$A$1" Then
        If Not IsNumeric(Target) Then
            MsgBox "Enter a number in cell A1."
            Range("A1").ClearContents
            Range("A1").Activate
        End If
    End If
End Sub

The event-handler procedure for the SelectionChange event

 
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
    If Union(Target, Range("ToolbarRange")).Address = Range("ToolbarRange").Address Then
        CommandBars("myBar").Visible = True
    Else
        CommandBars("myBar").Visible = False
    End If
End Sub

To validate user input, one possible location for the code is the SheetChange() event procedure of the Workbook object.

 
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
    MsgBox (Sh.Name & " "& Target.Address)
End Sub

trace worksheet activate event

 
Sub Worksheet_Activate()
    Dim msgOutput As String
    msgOutput = "This worksheet is " &  Workheets(2).Name
    MsgBox (msgOutput)
End Sub

Track worksheet change event

 
Sub Worksheet_SelectionChange(ByVal Target As Range)
    Dim msgOutput As String
    msgOutput = "The name of this worksheet is " & Worlsheets(1).Name
    MsgBox (msgOutput)
    Worksheets(1).Select
End Sub

Use a Change event to take what is in the cell and insert the colon for you

 
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim ThisColumn As Integer
    Dim UserInput As String, NewInput As String
    ThisColumn = Target.Column
    If ThisColumn < 3 Then
        UserInput = Target.Value
        If UserInput > 1 Then
            NewInput = Left(UserInput, Len(UserInput) - 2) & ":" & _
            Right(UserInput, 2)
            Application.EnableEvents = False
            Target = NewInput
            Application.EnableEvents = True
        End If
    End If
End Sub

Use Event Parameters to cancel an event

 
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    Cancel = True
End Sub

Using the Change Event to Respond to Worksheet Changes

 
Private Sub Worksheet_Change(ByVal Target As Range) 
    Select Case Target.Address 
        Case "$B$1" 
            Debug.Print Target.Value 
        Case "$B$2" 
            Debug.Print Target.Value 
    End Select 
End Sub

Validating data entry in Worksheet change event

 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    Dim VRange As Range, cell As Range
    Dim Msg As String
    Dim ValidateCode As Variant
    Set VRange = Range("A1:C4")
    For Each cell In Target
        If Union(cell, VRange).Address = VRange.Address Then
            ValidateCode = EntryIsValid(cell)
            If ValidateCode = True Then
                Exit Sub
            Else
                Debug.Print "Cell " & cell.Address(False, False) & ":" & ValidateCode
                Application.EnableEvents = False
                cell.ClearContents
                cell.Activate
                Application.EnableEvents = True
            End If
        End If
    Next cell
End Sub
Function EntryIsValid(cell) As Variant
    If cell = "" Then
        EntryIsValid = True
        Exit Function
    End If
    If Not IsNumeric(cell) Then
        EntryIsValid = "Non-numeric entry."
        Exit Function
    End If
    If CInt(cell) <> cell Then
        EntryIsValid = "Integer required."
        Exit Function
    End If
    If cell < 1 Or cell > 12 Then
        EntryIsValid = "Valid values are between 1 and 12."
        Exit Function
    End If
    EntryIsValid = True
End Function

With each range selection you make in the worksheet, the background color of the selection will turn blue.

 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    Target.Interior.Color = vbBlue
End Sub

Worksheet_Calculate()

 
Private Sub Worksheet_Calculate()
    Select Case Range("C3").Value
        Case Is < Range("C4").Value
            SetArrow 10, msoShapeDownArrow
        Case Is > Range("C4").Value
            SetArrow 3, msoShapeUpArrow
    End Select
End Sub
Private Sub SetArrow()
    " The following code is added to remove the prior shapes
    For Each sh In ActiveSheet.Shapes
        If sh.Name Like "*Arrow*" Then
            sh.Delete
        End If
    Next sh
    ActiveSheet.Shapes.AddShape(20, 17.25, 43.5, 5, 10).Select
    With Selection.ShapeRange
        With .Fill
            .Visible = msoTrue
            .Solid
            .ForeColor.SchemeColor = 2
            .Transparency = 0#
        End With
        With .Line
            .Weight = 0.75
            .DashStyle = msoLineSolid
            .Style = msoLineSingle
            .Transparency = 0#
            .Visible = msoTrue
            .ForeColor.SchemeColor = 64
            .BackColor.RGB = RGB(255, 255, 255)
        End With
    End With
End Sub

Worksheet Change Events

 
Private Sub Worksheet_Change(ByVal Target As Excel.Range)
    MsgBox "Range " & Target.Address & " was changed."
End Sub

Worksheet_SelectionChange(ByVal Target As Range)

 
Private Sub Worksheet_SelectionChange(ByVal Target As Range) 
      If Not Intersect(Range("MyRange"), Target) Is Nothing Then
          Sheets(Array("Sheet5", "Sheet3", "Sheet1")).Select
      Else
          Me.Select
      End If
End Sub