VBA提取指定Range内拆分后唯一值并按规则拼接字符串的实现方案

你可以借助Scripting.Dictionary字典对象实现自动去重，不需要手动遍历比对，也可以规避原代码里Select、GoTo等冗余易出错的写法，完整实现如下：

Function GetUniqueProductSupport() As String
    Dim ws As Worksheet
    Dim lastCol As Long
    Dim targetRow As Long
    Dim cell As Range
    Dim dict As Object
    
    ' 初始化字典，后期绑定无需手动添加引用，兼容性更好
    Set dict = CreateObject("Scripting.Dictionary")
    Set ws = ThisWorkbook.Worksheets("Machine Specification")
    
    ' 提前缓存行号，避免重复调用Find方法降低效率
    targetRow = ws.Cells.Find("Product Support", lookat:=xlWhole).Row
    lastCol = ws.Cells(ws.Cells.Find("Parameters", lookat:=xlWhole).Row, ws.Columns.Count).End(xlToLeft).Column
    
    ' 遍历目标区域，提取拆分后元素存入字典自动去重
    For Each cell In ws.Range(ws.Cells(targetRow, 3), ws.Cells(targetRow, lastCol))
        If Trim(cell.Value) <> "" Then
            Dim splitArr As Variant
            splitArr = Split(cell.Value, " , ")
            ' 增加下标判断，避免拆分元素不足时报下标越界错误
            If UBound(splitArr) >= 1 Then
                Dim currentVal As String
                currentVal = Trim(splitArr(1))
                If Not dict.exists(currentVal) Then
                    dict.Add currentVal, True
                End If
            End If
        End If
    Next cell
    
    ' 按规则拼接结果
    Select Case dict.Count
        Case 0: GetUniqueProductSupport = ""
        Case 1: GetUniqueProductSupport = dict.Keys()(0)
        Case Else: GetUniqueProductSupport = Join(dict.Keys(), " and ")
    End Select
End Function

使用方式 #

直接调用函数即可得到结果，示例：

' 输出到立即窗口
Debug.Print GetUniqueProductSupport()
' 写入单元格
ThisWorkbook.Worksheets("Sheet1").Range("A1").Value = GetUniqueProductSupport()

方案特点 #

• 利用字典自动去重，无需手动写比对逻辑，代码简洁易维护
• 所有单元格操作均绑定指定工作表，不会因为活动工作表切换出现异常
• 增加了空值、下标越界的异常处理，兼容性更强
• 封装为独立函数，可在任意位置重复调用，通用性好

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