如何合并两段VBA代码：实现带移除功能的多列表及值映射

• 合并两段VBA代码，实现两个核心功能：
  1. 带移除功能的多选列表：重复点击已选项目可移除，确保值唯一
  2. 长文本转短缩写：下拉列表显示长文本，选中后单元格显示对应预定义短缩写
• 现有两段代码分别实现单一功能，但因参数（Destination/Target）不同无法成功合并
• 额外需求：更新下拉选项或缩写映射时，已选中内容同步更新

Option Explicit
' 全局常量：统一管理分隔符、映射表位置
Const DELIMITER As String = " | "
Const MAP_SHEET As String = "PPE"
Const MAP_RANGE As String = "ShowAs"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim rngDropdown As Range
    Dim oldValue As String
    Dim newValue As String
    Dim newValueAbbr As String
    Dim arrOldAbbrs() As String
    Dim i As Integer
    Dim isExists As Boolean
    Dim lookupResult As Variant
    
    ' 只处理单个单元格的变更
    If Target.Count > 1 Then Exit Sub
    
    On Error Resume Next
    Set rngDropdown = Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo ExitError
    
    ' 过滤非下拉列表验证的单元格
    If rngDropdown Is Nothing Then GoTo ExitError
    If Intersect(Target, rngDropdown) Is Nothing Then GoTo ExitError
    If Target.Validation.Type <> 3 Then GoTo ExitError ' 3代表列表验证类型
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 获取用户选择的原始长文本，再回退获取变更前的旧值
    newValue = Target.Value
    Application.Undo
    oldValue = Target.Value
    Target.Value = newValue
    
    ' 选择空值则直接清空单元格
    If newValue = "" Then
        Target.Value = ""
        GoTo Cleanup
    End If
    
    ' 查找对应缩写，找不到则用原文本兜底
    lookupResult = Application.VLookup(newValue, ThisWorkbook.Worksheets(MAP_SHEET).Range(MAP_RANGE), 2, False)
    newValueAbbr = IIf(IsError(lookupResult), newValue, lookupResult)
    
    ' 处理旧值：检查缩写是否已存在
    If oldValue <> "" Then
        arrOldAbbrs = Split(oldValue, DELIMITER)
        isExists = False
        For i = LBound(arrOldAbbrs) To UBound(arrOldAbbrs)
            If arrOldAbbrs(i) = newValueAbbr Then
                isExists = True
                Exit For
            End If
        Next i
        
        If isExists Then
            ' 已存在则移除该缩写
            Target.Value = ""
            For i = LBound(arrOldAbbrs) To UBound(arrOldAbbrs)
                If arrOldAbbrs(i) <> newValueAbbr Then
                    Target.Value = Target.Value & arrOldAbbrs(i) & DELIMITER
                End If
            Next i
            ' 移除末尾多余分隔符
            If Target.Value <> "" Then
                Target.Value = Left(Target.Value, Len(Target.Value) - Len(DELIMITER))
            End If
        Else
            ' 不存在则添加新缩写
            Target.Value = oldValue & DELIMITER & newValueAbbr
        End If
    Else
        ' 旧值为空，直接设置新缩写
        Target.Value = newValueAbbr
    End If
    
Cleanup:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    Exit Sub
    
ExitError:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

' 处理映射/下拉选项更新时的同步
Private Sub Worksheet_Calculate()
    Dim updateRng As Range
    Dim cell As Range
    Dim arrAbbrs() As String
    Dim i As Integer
    Dim fullText As String
    Dim lookupResult As Variant
    
    On Error Resume Next
    Set updateRng = Cells.SpecialCells(xlCellTypeAllValidation)
    On Error GoTo ExitCalc
    
    If updateRng Is Nothing Then Exit Sub
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    For Each cell In updateRng
        If cell.Validation.Type = 3 And cell.Value <> "" Then
            arrAbbrs = Split(cell.Value, DELIMITER)
            cell.Value = ""
            ' 反向查找缩写对应的长文本，再匹配最新的缩写映射
            For i = LBound(arrAbbrs) To UBound(arrAbbrs)
                lookupResult = Application.Index(ThisWorkbook.Worksheets(MAP_SHEET).Range(MAP_RANGE).Columns(1), _
                    Application.Match(arrAbbrs(i), ThisWorkbook.Worksheets(MAP_SHEET).Range(MAP_RANGE).Columns(2), 0))
                If Not IsError(lookupResult) Then
                    fullText = lookupResult
                    lookupResult = Application.VLookup(fullText, ThisWorkbook.Worksheets(MAP_SHEET).Range(MAP_RANGE), 2, False)
                    cell.Value = cell.Value & IIf(IsError(lookupResult), fullText, lookupResult) & DELIMITER
                End If
            Next i
            ' 移除末尾分隔符
            If cell.Value <> "" Then
                cell.Value = Left(cell.Value, Len(cell.Value) - Len(DELIMITER))
            End If
        End If
    Next cell
    
ExitCalc:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

核心逻辑整合 #

• 参数统一：直接使用Worksheet_Change标准的Target参数，抛弃原代码中的Destination，彻底解决参数冲突问题
• 多选移除功能：将单元格已有的缩写拆分为数组，检查新选择内容的缩写是否存在——存在则移除，不存在则添加，确保内容唯一
• 缩写映射：用户选择长文本后，立即通过VLookup转换为缩写，后续操作均基于缩写处理，下拉列表保留原长文本不影响识别

额外需求处理 #

• 新增Worksheet_Calculate事件，当映射表或下拉选项更新时（按F9触发，或设置映射表为动态区域自动触发），自动遍历所有带下拉验证的单元格，重新匹配最新的缩写映射，实现内容同步更新
• 全局常量定义：将分隔符、映射表位置设为常量，后续修改无需翻找代码，直接修改常量即可

使用注意事项 #

• 映射表PPE的ShowAs区域必须是两列结构：第一列为下拉列表的长文本，第二列为对应短缩写
• 若需限制仅特定列生效，可在Worksheet_Change开头添加If Target.Column <> 2 Then Exit Sub（示例为仅第二列）
• 若VLookup找不到对应缩写，会自动使用原长文本显示，避免报错

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