即使不满足 if-criteria 的 Excel VBA 执行私有子

Question

我正在使用Private Sub Worksheet_Change(ByVal Target As Range) 对每个单元格中Range("AV9:AV" & lastrow) 的更改做出反应，这是一个下拉列表，其定义如下：

Dim lastrow2 As Long
Dim lastcell As Long

lastrow2 = Tabelle3.Range("A" & Rows.Count).End(xlUp).Offset(8).Row
lastcell = Tabelle3.Range("AH1048576").End(xlUp).Row  

For Each Cell In Tabelle3.Range(Tabelle3.Cells(9, 48), Tabelle3.Cells(lastcell, 48))

    If Cell = "" Then

            Dim MyList(2) As String

                MyList(0) = "Relevant"
                MyList(1) = "For Discussion"
                MyList(2) = "Not Relevant"


            With Tabelle3.Range("AV9:AV" & lastrow2).Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                     Operator:=xlBetween, Formula1:=Join(MyList, Application.International(xlListSeparator))
            End With

    End If

Next

这些行被合并到一个宏中，该宏用数据和所有必要的功能（例如下拉字段）填充Tabelle3。

Private Sub Worksheet_Change(ByVal Target As Range) 定义如下：

Private Sub Worksheet_Change(ByVal Target As Range)

Dim lastrow As Long

lastrow = Tabelle3.Range("A" & Rows.Count).End(xlUp).Offset(8).Row

    On Error Resume Next

    If Not Intersect(Target, Range("AV9:AV" & lastrow)) Is Nothing And Target.Value = "Relevant" Or Target.Value = "For Discussion" Then
        Application.CutCopyMode = False
        Cells(Target.Row, "A").Resize(, 57).Copy
        Tabelle14.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        Tabelle14.Range("A" & Rows.Count).End(xlUp).PasteSpecial xlPasteFormats
        Tabelle14.Range("A" & Rows.Count).End(xlUp).PasteSpecial xlPasteColumnWidths

        Application.CutCopyMode = False

    End If


    If Not Intersect(Target, Range("AV9:AV" & lastrow)) Is Nothing And Target.Value <> "" Then
        Cells(Target.Row, "A").Resize(, 2).Copy
        Tabelle10.Range("A" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlPasteValues
        Application.CutCopyMode = False

    End If

'//Delete all duplicate rows
Set Rng = Tabelle10.UsedRange
Rng.RemoveDuplicates Columns:=Array(1)


End Sub

如您所见，Private Sub Worksheet_Change(ByVal Target As Range) 的第一部分“应该”只执行 If in a dropdown field in Range("AV9:AV" & lastrow) the option 'Relevant' or 'For Discussion' is selected 和第二部分 If anything is selceted，因此我使用了 Target.Value <> ""。这主要工作正常，但发生了一个错误。

如果我通过已经提到的宏将数据插入到Tabelle3，似乎Private Sub Worksheet_Change(ByVal Target As Range) 会自动为row 9 in Tabelle3 执行，我可以在Tabelle14 和Tabelle10 中找到它的数据。

有人知道这里发生了什么吗？

Answer 1

尝试进行以下更改：

---

Option Explicit

Public Sub SetTabelle3Validation()

    Const V_LIST = "Relevant,For Discussion,Not Relevant"

    Dim ws As Worksheet:    Set ws = Tabelle3
    Dim lr As Long:         lr = ws.Range("AV" & ws.Rows.Count).End(xlUp).Row
    Dim app As Application: Set app = Application

    Dim fc As Range

    If lr > 9 Then
        Set fc = ws.Range(ws.Cells(9, "AV"), ws.Cells(lr, "AV"))
        fc.Validation.Delete

        fc.AutoFilter Field:=1, Criteria1:="<>"
        If fc.SpecialCells(xlCellTypeVisible).Cells.Count > 1 Then
            app.EnableEvents = False
            app.ScreenUpdating = False
            With fc.SpecialCells(xlCellTypeVisible).Validation
              .Add Type:=xlValidateList, _
                   AlertStyle:=xlValidAlertStop, _
                   Operator:=xlBetween, _
                   Formula1:=Join(Split(V_LIST, ","), app.International(xlListSeparator))
            End With
            app.ScreenUpdating = True
            app.EnableEvents = True
        End If
        fc.AutoFilter
    End If
End Sub

---

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim lr As Long:         lr = Me.Rows.Count
    Dim lrT3 As Long:       lrT3 = Me.Range("A" & lr).End(xlUp).Offset(8).Row
    Dim app As Application: Set app = Application
    Dim inAV As Boolean

    inAV = Not Intersect(Target, Me.Range("AV9:AV" & lrT3)) Is Nothing

    With Target
        If .Cells.CountLarge > 1 Or Not inAV Or Len(.Value) = 0 Then Exit Sub

        app.EnableEvents = False
        If .Value = "Relevant" Or .Value = "For Discussion" Then
            Me.Cells(.Row, "A").Resize(, 57).Copy
            With Tabelle14.Range("A" & lr).End(xlUp).Offset(1)
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                .PasteSpecial xlPasteColumnWidths
            End With
            Tabelle14.UsedRange.RemoveDuplicates Columns:=Array(1)
        End If

        Me.Cells(.Row, "A").Resize(, 2).Copy
        With Tabelle10
            .Range("A" & lr).End(xlUp).Offset(1).PasteSpecial xlPasteValues
            .UsedRange.RemoveDuplicates Columns:=Array(1)
        End With
        app.CutCopyMode = False
        app.EnableEvents = True
    End With
End Sub

---

在SetTabelle3Validation()

• 用AutoFilter 替换For 循环以获得速度
• 关闭Application.EnableEvents 以停止触发Worksheet_Change()（然后重新打开）

在Worksheet_Change()

• 如果粘贴多个值，则退出 Sub，Target 不在 col AV 中，或者为空
• Else（Target 在列AV 中，并且不为空）
  • 关闭Application.EnableEvents 关闭
  • 如果Target值为"Relevant"或"For Discussion"，则更新Tabelle14
  • 否则（Target值为"Not Relevant"），更新Tabelle10
  • 打开Application.EnableEvents

---

假设

• 所有以Tabelle 开头的对象都是其他工作表的代号
• Worksheet_Change() 属于 Tabelle3