代码之家 › 专栏 › 技术社区 › HPM

Excel VBA对私有子级的执行,即使条件未满

if-statement excel-vba vba excel

HPM · 技术社区 · 6 年前

我在用 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 包含数据和所有必要的函数,如下拉字段。

这个 私有子工作表更改(ByVal目标作为范围) 定义如下:

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

正如你所看到的 私有子工作表更改(ByVal目标作为范围) “should”只能执行 If in a dropdown field in Range("AV9:AV" & lastrow) the option 'Relevant' or 'For Discussion' is selected 第二部分 If anything is selceted 因此我用 Target.Value <> "" . 这主要工作正常,但会出现一个错误。

如果我将数据插入 表3 通过前面提到的宏,似乎 私有子工作表更改(ByVal目标作为范围) 然后自动执行 row 9 in Tabelle3 我可以在 Tabelle14 和 Tabelle10 如定义。

有人知道这是怎么回事吗?

1 回复 | 直到 6 年前

paul bica 6 年前

尝试进行以下更改:

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()

更换 For 循环 AutoFilter 对于速度
转弯 Application.EnableEvents 关闭以停止触发 Worksheet_Change() (然后再打开)

在 工作表更改()

如果粘贴多个值、目标不在列AV中或为空,则退出Sub。
否则( Target 在列中 AV ,不为空)
- 转弯 应用程序.enableEvents 下车
- 如果 靶标 值是 "Relevant" 或 "For Discussion" ,更新 Tabelle14
- 否则( 靶标 值是 "Not Relevant" )更新 Tabelle10
- 转弯 应用程序.enableEvents 论

假设

所有对象从开始 Tabelle 是吗? 代码名称 其他页
工作表更改() 属于 Tabelle3