实现整行下拉列表多选的VBA代码问题

修改后的代码 #

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Oldvalue As String
    Dim Newvalue As String
    Dim cell As Range
    
    ' 只处理D2:D13范围内的单元格
    If Not Intersect(Target, Range("$D$2:$D$13")) Is Nothing Then
        Application.EnableEvents = False
        On Error GoTo Exitsub
        
        ' 遍历目标范围内的每个单元格（兼容批量修改场景）
        For Each cell In Intersect(Target, Range("$D$2:$D$13"))
            ' 跳过无数据验证（下拉列表）的单元格
            If cell.SpecialCells(xlCellTypeAllValidation) Is Nothing Then
                GoTo NextCell
            End If
            
            ' 跳过空值
            If cell.Value = "" Then GoTo NextCell
            
            Newvalue = cell.Value
            Application.Undo
            Oldvalue = cell.Value
            
            If Oldvalue = "" Then
                cell.Value = Newvalue
            Else
                ' 避免重复添加同一选项
                If InStr(1, Oldvalue, Newvalue) = 0 Then
                    cell.Value = Oldvalue & ", " & Newvalue
                Else
                    cell.Value = Oldvalue
                End If
            End If
NextCell:
        Next cell
    End If

Exitsub:
    Application.EnableEvents = True
End Sub

关键修改说明 #

• 范围匹配逻辑：用Intersect(Target, Range("$D$2:$D$13"))替代原代码的逐个单元格地址判断，只要修改的单元格落在目标范围内就会触发处理，解决了无法应用到整列的问题。
• 批量修改兼容：添加For Each循环遍历目标单元格，支持批量粘贴、多选修改等场景，避免单个单元格判断的遗漏。
• 事件控制优化：将事件关闭操作移到范围判断之后，减少不必要的资源占用；错误分支确保无论是否出错，最后都会重新开启事件，防止后续代码无法触发工作表变更事件。
• 逻辑简化：调整嵌套结构，让代码可读性更强，减少冗余判断。

内容的提问来源于stack exchange，提问作者Vibes