☰

从一列中提取唯一值并合并到一个单元格中。Excel VBA

tag-icon • tag-icon microsoft-excel vba
从一列中提取唯一值并合并到一个单元格中。Excel VBA

(D) 列中有重复的值。

如何使用 vba 从 D 列中提取唯一值并合并到单个单元格 (H1) 中而不丢失数据

例如：“J10P，G345，R1，J10G”

我尝试使用此代码来提取唯一值，但它并不准确：

ActiveSheet.Columns(4).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=ActiveSheet.Range("H1"), Unique:=True

编辑：我发现此代码仅提取唯一值并放入列（H），我测试过并且可以工作。现在我只需要代码来合并 H 列中的单元格

' Extract unique values from Column D       
Dim D As Object, C As Variant, i As Long, lr As Long
Set D = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 1).End(xlUp).Row
C = Range("D1:D" & lr)
For i = 1 To UBound(C, 1)
  D(C(i, 1)) = 1
Next i
Range("H1").Resize(D.Count) = Application.Transpose(D.keys)

在此处输入图片描述

答案1

如果您有 Microsoft 365 (Office 365)，则可以使用以下公式来获得所需结果。我假设您希望在逗号两侧留有空格。

编辑——感谢 Máté Juhász 的建议。

 =TEXTJOIN(" , ",TRUE,UNIQUE(D1:D7))

根据 OP 选择的代码的基于 VBA 的解决方案。

在 Excel 中按ATL+F11打开 VBA 编辑器。插入一个模块并添加以下两个用户定义函数 (UDF)。

Function UNIQUE1()

Application.Volatile
Dim D As Object, C As Variant, i As Long, lr As Long
Set D = CreateObject("Scripting.Dictionary")
lr = Cells(Rows.Count, 4).End(xlUp).Row
C = Range("D1:D" & lr)
For i = 1 To UBound(C, 1)
  D(C(i, 1)) = 1
Next i

UNIQUE1 = Application.Transpose(D.keys)


End Function


Function TEXTJOIN1(delimiter As String, ignore_empty As Boolean, ParamArray cell_ar() As Variant)
    Application.Volatile
    For Each cellrng In cell_ar
        For Each cell In cellrng
            If ignore_empty = False Then
                result = result & cell & delimiter
            Else
                If cell <> "" Then
                    result = result & cell & delimiter
                End If
            End If
        Next cell
    Next cellrng
    TEXTJOIN1 = Left(result, Len(result) - Len(delimiter))
End Function

这将创建两个名为 UNIQUE1 和 TEXTJOIN1 的用户定义函数。保存并退出 VBA 编辑器。

现在在 H1 中输入以下公式。

=TEXTJOIN1(" , ", TRUE, unique1())

在此处输入图片描述

请注意以下事项

  • 您的代码经过了轻微修改，并由此创建了一个 UDF。此外，它使用第 4 列作为 D 列，lr = Cells(Rows.Count, 4).End(xlUp).Row因为在我的示例中没有完整的表格。我只填充了 D 列
  • Application.Volatile添加以使其在适用时自动计算
  • 需要 TEXTJOIN1 UDF，因为您的 Excel 版本没有内置此功能。
  • 将工作簿另存为 .xlsm 宏已启用

相关内容