Question

我希望自动化我的VBA，而不必在每次有人更改单元格时运行VBA。我尝试使用Worksheet_Change（ByRef Target As Range），但是我遇到了编译器错误。下面是我的代码，没有使用worksheet_change事件。这是一个共享的excel工作簿，因此每当有人填写新单元格或进行更改时，我都需要将其自动化。

 Option Explicit

 Public Sub getEmails()

 Dim names As Range, findRange As Range
 Dim splitNames
 Dim selectedEmails As String, i As Long, lRow As Long

 Set names = Sheets("Email").Range("B1:C23") ' names range from lookup table from    different worksheet


With Sheets("Sheet2")
' loop column K untill last row with data (staring from row 2 >> modify where you data starts)
For lRow = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
    ' fill array directly from cell
    splitNames = Split(.Range("B" & lRow), ",")

    For i = 0 To UBound(splitNames)
        ' find the range matching the name
        Set findRange = names.Find(What:=Trim(splitNames(i)), LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

        ' if match found, get the email and store to selected emails variable
        If Not findRange Is Nothing Then
            If selectedEmails = "" Then ' first email of this row
                selectedEmails = findRange.Offset(0, 1).Value
            Else  ' add a ";" to separate email addresses
                selectedEmails = selectedEmails & "; " & findRange.Offset(0, 1).Value
            End If

        End If
    Next i

    .Range("C" & lRow) = selectedEmails
    ' clrear all variables and arrays for next cycle
    Erase splitNames
    selectedEmails = ""
Next lRow

End With

End Sub

Answer 1

Private Sub Worksheet_Change(ByRef Target As Range)＆lt; - ByRef：错误

应该是：

Private Sub Worksheet_SelectionChange(ByVal Target As Range)  '<-- ByVal

这应该是sub的原型，它应该放在Sheet2代码模块中（就像你已经做过的那样）。

<强>附录

这是你的sub的重构版本，应该更快，更易于维护。它仅在B列中发生更改时触发操作，并且仅对已更改的部分起作用，更新C列中的相邻单元格。

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim B As Range: Set B = Range("B2:B" & Cells(Rows.count, "B").End(xlUp).Row)
    Dim r As Range: Set r = Intersect(B, Target)
    If r Is Nothing Then Exit Sub

    Dim findRange As Range, selectedEmails As String, i

    On Error GoTo Finish
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Dim names As Range: Set names = Sheets("Email").Range("B1:C23")  ' names range from lookup table from    different worksheet
    Dim cel As Range
    For Each cel In r
       Dim splitNames : splitNames = Split(cel.value, ",")
       For Each i In splitNames
           ' find the range matching the name
           Set findRange = names.Find(What:=Trim(i), LookIn:=xlFormulas, _
               LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
               MatchCase:=False, SearchFormat:=False)

            ' if match found, get the email and store to selected emails variable
            If Not findRange Is Nothing Then
                If selectedEmails = "" Then ' first email of this row
                    selectedEmails = findRange.Offset(0, 1).Value
                Else  ' add a ";" to separate email addresses
                    selectedEmails = selectedEmails & "; " & findRange.Offset(0, 1).Value
                End If
            End If
        Next i
        cel.Offset(, 1).Value = selectedEmails
        selectedEmails = ""
    Next cel

Finish:
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

Answer 2

确保您的Worksheet_Change事件位于您正在使用的工作表后面而不是模块中。右键单击工作表，然后选择“查看代码”。将代码放入打开的窗口中。

检查一下。

http://www.excel-easy.com/vba/events.html

Excel - 无需每次运行即可自动执行VBA

2 个答案: