Question

首先，我对长篇文章表示歉意，我正在努力在VBA上创建一个更改事件，在该事件中创建了多个范围的注释。我有下面的代码可以在一个范围内工作，但是当我尝试将其扩展到另一个范围时，要么发生错误，要么根本不读取代码。任何帮助将不胜感激。

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Author, EmployeeName, SiteName, ShiftTimes, PayRate As String
Dim DateEntered As Date
Dim intRow As Integer
Dim cmt As Comment
Dim lBreak As Long

If Intersect(Target, Range("C4:AG19")) Is Nothing Then Exit Sub
intRow = Target.Row
Author = Application.UserName
EmployeeName = Application.WorksheetFunction.Index(Range("$B$4:$B$19"), Target.Row)
SiteName = Range("B2").Value
ShiftTimes = Application.VLookup(Target.Value, Range("AI10:AJ13"), 2, False)
SitePayRate = format((Range("AJ7").Value), "£#,##0.00") & " p/h"
DateEntered = Now()

With Target
    .ClearComments
    .AddComment Author & Chr(10) _
    & EmployeeName & Chr(10) _
    & SiteName & Chr(10) _
    & ShiftTimes & Chr(10) _
    & PayRate & Chr(10) _
    & DateEntered
    .Comment.Shape.TextFrame.AutoSize = True
    .Comment.Visible = False
End With

Set cmt = Target.Comment
If cmt Is Nothing Then
    Exit Sub
End If

'find the line break which is Chr(10)
lBreak = InStr(1, cmt.Text, Chr(10))

'format username in red and bold
With cmt.Shape.TextFrame
    .Characters.Font.Bold = False
    .Characters(1, lBreak).Font.ColorIndex = 1
    .Characters(1, lBreak).Font.Bold = True
    .Characters(lBreak + 1, Len(cmt.Text)).Font.ColorIndex = 1
End With
End Sub

我希望实现的是，当目标范围为（C32：AG40）时，它将调用数据表中的以下信息

If Intersect(Target, Range("C32:AG40")) Is Nothing Then Exit Sub
intRow = Target.Row
Author = Application.UserName
EmployeeName = Application.WorksheetFunction.Index(Range("$B$32:$B$40"), Target.Row)
SiteName = Range("B30").Value
ShiftTimes = Application.VLookup(Target.Value, Range("AI38:AJ41"), 2, False)
SitePayRate = format((Range("AJ35").Value), "£#,##0.00") & " p/h"
DateEntered = Now()

我希望我已经清楚地说明了自己，再次感谢您的帮助。

Answer 1

我建议您避免使用“如果相交...则退出子项”

Private Sub Worksheet_Change(ByVal Target As Range)
    '...
    If Not (Intersect(Target, Range("C4:AG19")) Is Nothing) Then
        '...
        Debug.Print "Range C4:AG19"

    ElseIf Not (Intersect(Target, Range("C32:AG40")) Is Nothing) Then
        '...
        Debug.Print "Range C32:AG40"
    End If
End Sub

Answer 2

尝试

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim Author, EmployeeName, SiteName, ShiftTimes, PayRate As String
    Dim DateEntered As Date
    Dim intRow As Integer
    Dim cmt As Comment
    Dim lBreak As Long

    Dim rngIndex As Range, rngSitName As Range, rngTime As Range
    Dim rngRate As Range
    Dim Rng1 As Range, Rng2 As Range

    Set Rng1 = Range("C4:AG19")
    Set Rng2 = Range("C32:AG40")

    If Intersect(Target, Union(Rng1, Rng2)) Is Nothing Then Exit Sub

    If Not Intersect(Target, Rng1) Is Nothing Then
        Set rngIndex = Range("AI10:AJ13")
        Set rngSitName = Range("B2")
        Set rngTime = Range("AI10:AJ13")
        Set rngRate = Range("AJ7").Value
    ElseIf Not Intersect(Target, Rng2) Is Nothing Then
        Set rngIndex = Range("AI38:AJ41")
        Set rngSitName = Range("B30")
        Set rngTime = Range("AI10:AJ13")
        Set rngRate = Range("AJ35").Value
    End If

    intRow = Target.Row
    Author = Application.UserName
    EmployeeName = Application.WorksheetFunction.Index(rngIndex, Target.Row)
    SiteName = rngSitName
    ShiftTimes = Application.VLookup(Target.Value, rngTime, 2, False)
    SitePayRate = Format(rngRate, "￡#,##0.00") & " p/h"
    DateEntered = Now()

    With Target
        .ClearComments
        .AddComment Author & Chr(10) _
        & EmployeeName & Chr(10) _
        & SiteName & Chr(10) _
        & ShiftTimes & Chr(10) _
        & PayRate & Chr(10) _
        & DateEntered
        .Comment.Shape.TextFrame.AutoSize = True
        .Comment.Visible = False
    End With

    Set cmt = Target.Comment
    If cmt Is Nothing Then
        Exit Sub
    End If

    'find the line break which is Chr(10)
    lBreak = InStr(1, cmt.Text, Chr(10))

    'format username in red and bold
    With cmt.Shape.TextFrame
        .Characters.Font.Bold = False
        .Characters(1, lBreak).Font.ColorIndex = 1
        .Characters(1, lBreak).Font.Bold = True
        .Characters(lBreak + 1, Len(cmt.Text)).Font.ColorIndex = 1
    End With
End Sub

vba更改事件多个目标

2 个答案: