в 16:33, 26 мая 2010

2010-05-26T16:33:00Z

Admin: 1 версия

2010-05-26T12:47:47Z

1 версия

Новая страница

==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>

← Предыдущая	Версия 16:33, 26 мая 2010
(нет различий)

VBA/Excel/Access/Word/Excel/Worksheet Event - История изменений

в 16:33, 26 мая 2010

Admin: 1 версия