即使可以防止非目标单元运行，Worksheet_Change函数也可以运行

时间：2019-01-03 15:59:35

标签： excel vba excel-vba

我有两个代码，一个在模块中，另一个在sheet1中。 Sheet1中的代码是Worksheet_Change代码。每当我尝试在Module中运行代码时，都会出现错误并激活sheet1代码。

我浏览了论坛，并尝试了为Private Sub指定目标单元并使用EnableEvents = False解决方案的解决方案。这些都不起作用。 sheet1中的代码也无法正常运行，并且一起执行所有代码。

Private Sub Worksheet_Change(ByVal Target As range)

Dim KeyCell As range

Set KeyCell = range("A1:J1")    

If Not Application.Intersect(KeyCell, Me.range(A1)) Is Nothing Then
    OffEmp range("B151:B210"), False

    If range("A1") = "A Off" Then
        OffEmp range("B151:B210"), True
    ElseIf range("A1") = "A" Then
            range("B151:B210").ClearContents
    End If
End If
'After executing the above code it jumps to this code and executes it even when Cell B1 is not changed.

If Not Application.Intersect(KeyCell, Target) Is Nothing Then
    OffEmp range("B151:B210"), False
    If range("B1") = "B Off" Then
        OffEmp range("B2:B9"), True
    ElseIf range("B1") = "B" Then
            range("B151:B210").ClearContents
    End If
End If

每当我尝试更改A1中的任何内容时，代码都会运行并粘贴内容，并同时将其清除。 Off range（），False / True是不同的Sub，如下所示：

Sub Off(R As range, Off As Boolean)
    With R.Select
             Selection.Copy
         If Off Then
            If IsEmpty(range("$B$151")) = True Then
                    range("$B$151").Select
                Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
                SkipBlanks:=False, Transpose:=False
            ElseIf IsEmpty(range("$B$151")) = False Then
                    range("$B$151").Activate
                    ActiveCell.End(xlDown).Offset(1, 0).Select
                    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
                    SkipBlanks:=False, Transpose:=False
            End If
        End If
    End With
End Sub

我试图作为模块运行的代码是：

Option Explicit
'use a constant to store the highlight color...
Const HIGHLIGHT_COLOR = 9894500 'RGB(100, 250, 150)'Is a cell highlighted? 
EDIT: changed the function name to IsHighlighted

Sub AssignBided()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim cel1 As range
Dim cel2 As range
Dim Bid As range
Dim line As range
Dim Offemp As range
Dim BidL8 As range
Dim BidL8E As range
Dim coresVal As String

Set ws1 = Worksheets("Sheet1")
Set ws2 = Worksheets("Sheet2")
Set Bid = ws2.range("$D$12:$D$40, $D$43:$D$58, $D$61:$D$77, $D$81:$D$97, $D$101:$D$117")
Set line = ws2.range("$B$12:$B$40, $B$43:$B$58, $B$61:$B$77, $B$81:$B$97, $B$101:$B$117")
Set Offemp = ws2.range("$B$151:$B$210")
Set BidL8 = ws1.range("$R$27:$R$263")
Set BidL8E = ws1.range("$S$27:$S$263")

For Each cel2 In line
    If IsHighlighted(cel2) Then
        For Each cel1 In BidL8E
            If Application.WorksheetFunction.CountIf(Offemp, cel1.Value) > 0 Then
            Else: cel2.Offset(0, 2).Activate
                    ActiveCell.FormulaR1C1 = "=INDEX(Sheet1!$S$27:$S$263,MATCH(" & cel2.Value & ",Sheet1!$R$27:$R$263,0))"
            End If
        Next cel1
    End If
Next cel2
End Sub
Function IsHighlighted(c As range)
    IsHighlighted = (c.Interior.Color = HIGHLIGHT_COLOR)
End Function

对于这个冗长的问题，我感到抱歉。但我在这里解决。每当我更改单元格A1时，代码就会运行并按需粘贴内容，但同时也会清除它。同样，当我运行模块时，它会执行代码，但是在尝试将名称粘贴到单元格中时会触发Private Sub。有什么方法可以使这项工作吗？或有什么建议会对此有所帮助？ 谢谢您的提前努力。

2 个答案:

答案 0 :(得分：1)

您是否不能将公共变量（例如modRun或其他东西）设置为1，然后在工作表的子目录开头，检查该变量以查看其是否为1，然后退出子目录？ 只需确保在模块末尾将变量设置回零即可。

答案 1 :(得分：0)

好的，所以我找到了解决这个问题的简单但不是简短的解决方案。 我只是将每个目标单元格定义为不同的变量。之所以有效，是因为它没有触发其余代码。 它不是一个很好的解决方案，但是可以达到我希望它达到的目的。 我正在发布整个代码，如果有人可以帮助我减少行数或知道一种更好的方法来处理它，将不胜感激。感谢您的所有答复和建议。

'Remove Case Sensitivity
Option Compare Text
Private Sub Worksheet_Change(ByVal Target As range)

Dim KeyCell1 As range
Dim KeyCell2 As range
Dim KeyCell3 As range
Dim KeyCell4 As range
Dim KeyCell5 As range
Dim KeyCell6 As range
Dim KeyCell7 As range
Dim KeyCell8 As range
Dim KeyCell9 As range
Dim KeyCell10 As range
Dim KeyCell11 As range

Set KeyCell1 = range("A1")
Set KeyCell2 = range("B1")
Set KeyCell3 = range("C1")
Set KeyCell4 = range("D1")
Set KeyCell5 = range("E1")
Set KeyCell6 = range("F1")
Set KeyCell7 = range("G1")
Set KeyCell8 = range("H1")
Set KeyCell9 = range("I1")
Set KeyCell10 = range("J1")
Set KeyCell11 = range("Line8_P_Mon, Line10_P_Mon, Line11_P_Mon, Line12_P_Mon")

If Not Application.Intersect(KeyCell1, Target) Is Nothing Then
    OffEmp range("Off_Mon"), False

    If range("A1") = "A Off" Then
        OffEmp range("A2:A9"), True
    ElseIf range("A1") = "A" Then
            range("Off_Mon").ClearContents
    End If
End If

If Not Application.Intersect(KeyCell2, Target) Is Nothing Then
    OffEmp range("Off_Mon"), False
    If range("B1") = "B Off" Then
        OffEmp range("B2:B9"), True
     ElseIf range("B1") = "B" Then
            range("Off_Mon").ClearContents
    End If
End If

If Not Application.Intersect(KeyCell3, Target) Is Nothing Then
    OffEmp range("Off_Mon"), False
    If InStr(1, range("C1"), "C Off") > 0 Then
        OffEmp range("C2:C9"), True
    ElseIf range("C1") = "C" Then
            range("Off_Mon").ClearContents
    End If
End If

If Not Application.Intersect(KeyCell4, Target) Is Nothing Then
    OffEmp range("Off_Mon"), False
    If InStr(1, range("D1"), "D Off") > 0 Then
        OffEmp range("D2:D9"), True
    ElseIf range("D1") = "D" Then
            range("Off_Mon").ClearContents
    End If
End If

If Not Application.Intersect(KeyCell5, Target) Is Nothing Then
    OffEmp range("Off_Mon"), False
    If InStr(1, range("E1"), "E Off") > 0 Then
        OffEmp range("E2:E9"), True
    ElseIf range("E1") = "E" Then
            range("Off_Mon").ClearContents
    End If
End If

If Not Application.Intersect(KeyCell6, Target) Is Nothing Then
    OffEmp range("Off_Mon"), False
    If InStr(1, range("F1"), "F Off") > 0 Then
        OffEmp range("F2:F9"), True
    ElseIf range("F1") = "F" Then
            range("Off_Mon").ClearContents
    End If
End If

If Not Application.Intersect(KeyCell7, Target) Is Nothing Then
    OffEmp range("Off_Mon"), False

    If InStr(1, range("G1"), "G Off") > 0 Then
        OffEmp range("G2:G9"), True
    ElseIf range("G1") = "G" Then
            range("Off_Mon").ClearContents
    End If
End If

If Not Application.Intersect(KeyCell8, Target) Is Nothing Then
    OffEmp range("Off_Mon"), False
    If InStr(1, range("H1"), "H Off") > 0 Then
        OffEmp range("H2:H9"), True
    ElseIf range("H1") = "H" Then
            range("Off_Mon").ClearContents
    End If
End If

If Not Application.Intersect(KeyCell9, Target) Is Nothing Then
    OffEmp range("Off_Mon"), False
    If InStr(1, range("I1"), "I Off") > 0 Then
        OffEmp range("I2:I9"), True
    ElseIf range("I1") = "I" Then
            range("Off_Mon").ClearContents
    End If
End If

If Not Application.Intersect(KeyCell10, Target) Is Nothing Then
    OffEmp range("Off_Mon"), False
    If InStr(1, range("J1"), "J Off") > 0 Then
        OffEmp range("J2:J9"), True
    ElseIf range("J1") = "J" Then
            range("Off_Mon").ClearContents
    End If
End If

有更多的代码行，并且所有范围都被命名。谢谢。

相关问题
最新问题