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

Материал из VB Эксперт
Перейти к: навигация, поиск

Содержание

Activating Only the Used Range

   <source lang="vb">

Private Sub Worksheet_Activate( )

     Me.ScrollArea = Range(Me.UsedRange, Me.UsedRange(2,2)).Address

End Sub

</source>
   
  


BeforeDoubleClick event

   <source lang="vb">

Private Sub Worksheet_BeforeDoubleClick _

   (ByVal Target As Excel.Range, Cancel As Boolean)
   Target.Font.Bold = Not Target.Font.Bold
   Cancel = True

End Sub

</source>
   
  


BeforeRightClick event

   <source lang="vb">

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

</source>
   
  


Cancel a change in Worksheet Selection Change event

   <source lang="vb">

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

</source>
   
  


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

   <source lang="vb">

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _

   Cancel As Boolean)
   Dim myColor As Integer
   Target.Interior.ColorIndex = 3

End Sub

</source>
   
  


Change the range color in selection change event

   <source lang="vb">

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


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

   <source lang="vb">

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

</source>
   
  


Create a function for Excel: Is a cell formula cell

   <source lang="vb">

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

=IsFormula(A1)

</source>
   
  


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

   <source lang="vb">

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

</source>
   
  


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

   <source lang="vb">

Private Sub Worksheet_Change(ByVal Target As Range)

   Application.EnableEvents = False
   Range("A1").Value = Target.Value
   Application.EnableEvents = True

End Sub

</source>
   
  


Enable Events

   <source lang="vb">

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


event procedure runs every time the worksheet recalculates

   <source lang="vb">

    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
</source>
   
  


Examples of Activation Events

   <source lang="vb">

Private Sub Worksheet_Activate()

   MsgBox "You just activated " & ActiveSheet.Name

End Sub

</source>
   
  


Example that activates cell A1 whenever the sheet is activated:

   <source lang="vb">

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

</source>
   
  


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

   <source lang="vb">

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

</source>
   
  


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

   <source lang="vb">

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

</source>
   
  


Monitoring a specific range for changes

   <source lang="vb">

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

</source>
   
  


Preventing data validation from being destroyed

   <source lang="vb">

         

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

</source>
   
  


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

   <source lang="vb">

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

</source>
   
  


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

   <source lang="vb">

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


The Change event

   <source lang="vb">

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

</source>
   
  


The event-handler procedure for the SelectionChange event

   <source lang="vb">

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

</source>
   
  


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

   <source lang="vb">

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)

   MsgBox (Sh.Name & " "& Target.Address)

End Sub

</source>
   
  


trace worksheet activate event

   <source lang="vb">

Sub Worksheet_Activate()

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

End Sub

</source>
   
  


Track worksheet change event

   <source lang="vb">

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

</source>
   
  


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

   <source lang="vb">

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

</source>
   
  


Use Event Parameters to cancel an event

   <source lang="vb">

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

   Cancel = True

End Sub

</source>
   
  


Using the Change Event to Respond to Worksheet Changes

   <source lang="vb">

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

</source>
   
  


Validating data entry in Worksheet change event

   <source lang="vb">

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

</source>
   
  


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

   <source lang="vb">

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

   Target.Interior.Color = vbBlue

End Sub

</source>
   
  


Worksheet_Calculate()

   <source lang="vb">

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

</source>
   
  


Worksheet Change Events

   <source lang="vb">

Private Sub Worksheet_Change(ByVal Target As Excel.Range)

   MsgBox "Range " & Target.Address & " was changed."

End Sub

</source>
   
  


Worksheet_SelectionChange(ByVal Target As Range)

   <source lang="vb">

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

</source>