（Excel）如何自动创建逗号分隔列表？ [关闭]

Question

我承认Excel远非我的力量，所以任何帮助都会受到赞赏。

我们在excel电子表格（约15,000行）中有大量数据需要报告。

对于A列中的每个项目，B列中有一个或多个值。

下表描述了我的意思，尽管规模非常小：

有没有办法让Excel运行这样的表，并且对于列A中的每个唯一值，为列B中的每个对应值编译逗号分隔列表。

即

感谢您的帮助。

Answer 1

这是为andy：

使用数组公式：

=TEXTJOIN(",",TRUE,IF(A1:A7="andy",B1:B7,""))

必须使用Ctrl + Shift + Enter输入数组公式，而不仅仅是Enter键。如果这样做正确，公式将在公式栏中以大括号显示。

为每个唯一名称重复该公式。

编辑＃1：

要自动执行此操作：

1. 将A列复制到C列
2. 使用Excel的RemoveDuplicates功能创建唯一名称列表
3. 将数组公式应用于该唯一列表的每个成员。

编辑＃2：

要使用VBA自动执行，请运行以下短宏：

Sub PleaseAutomate()
        Dim N As Long
        Dim M As Long

        M = Cells(Rows.Count, "A").End(xlUp).Row
        Columns(1).Copy Columns(3)
        Columns(3).RemoveDuplicates Columns:=1, Header:=xlNo
        N = Cells(Rows.Count, "C").End(xlUp).Row
        Range("D1").FormulaArray = "=TEXTJOIN("","",TRUE,IF($A$1:$A$" & M & "=C1,$B$1:$B$" & M & ",""""))"
        Range("D1").Copy Range("D2:D" & N)
End Sub

Answer 2

这将处理您的整个数据集。查看注释并在指定的两个位置更新范围。老实说，虽然你的数据来自哪里？我假设有一个数据库。您应该在数据Feed中处理此问题

Public Sub ValuestoStringSeparated()
    Dim Data As Variant, Results As Variant, tmp As Variant
    Dim Dict As Object
    Dim i As Long
    Dim Key

    Set Dict = CreateObject("Scripting.Dictionary")

    ' Update this to your sheet Ref
    With ActiveSheet
        Data = .Range(.Cells(2, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 2)).Value2
    End With

    ' Add your raw data to Dictionary
    For i = LBound(Data, 1) To UBound(Data, 1)
        If Not Dict.Exists(Data(i, 1)) Then
            ReDim tmp(0)
            tmp(0) = Data(i, 2)
            Dict.Add Key:=Data(i, 1), Item:=tmp
        Else
            tmp = Dict(Data(i, 1))
            ReDim Preserve tmp(LBound(tmp) To UBound(tmp) + 1)
            tmp(UBound(tmp)) = Data(i, 2)
            Dict(Data(i, 1)) = tmp
        End If
        Erase tmp
    Next i

    ' Print your Data to sheet
    ReDim Results(1 To Dict.Count, 1 To 2)
    i = 0
    For Each Key In Dict.keys
        i = i + 1
        Results(i, 1) = Key
        Results(i, 2) = Join(Dict(Key), ", ")
    Next Key

    ' Update with your desired output destination
    With ActiveSheet.Range("D2")
        .Resize(UBound(Results, 1), UBound(Results, 2)).Value2 = Results
    End With
End Sub

Answer 3

通过字典和数据字段数组的方法

类似于@Tom上面的好解决方案：+），但是已经在字典中加入保险类型并且避免了额外的tmp数组的常量ReDim Preserve。注意：我决定使用计数器而不是正确的LBound和UBound计数以获得更好的可读性，因此也允许简单的范围定义。

码

Option Explicit
Sub JoinTypes()
  Const DELI As String = ","
  Dim dict As Object, d
  Dim i    As Long, n As Long
  Dim sKey As String
  Dim v    As Variant, Results() As Variant
  Dim ws   As Worksheet
  Set ws = ThisWorkbook.Worksheets("Test")            ' << change to your sheet name
  Set dict = CreateObject("Scripting.Dictionary")     ' dictionary object

' [1] get last row in column A
  n = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
' [2] read data into 1-based 2-dim datafield array
  v = ws.Range("A1:B" & n)
' [3] get Customers and collect joined values into dictionary (omit title row)
  For i = 2 To n
      sKey = v(i, 1)
      If dict.Exists(sKey) Then                 ' join insurance types (delimiter ",")
         dict(sKey) = dict(sKey) & DELI & v(i, 2)
      Else                                      ' start new customer
         dict.Add key:=sKey, Item:=v(i, 2)
      End If
  Next i
  Erase v
' [4] write joined values into new array
   n = dict.Count                               ' redefine counter
   ReDim Results(1 To n, 1 To 2)                ' redimension new array ONLY ONCE :-)
   i = 0
   For Each d In dict.keys                      ' loop through customers in dictionary keys
       i = i + 1: Results(i, 1) = d: Results(i, 2) = dict(d)
   Next d
 ' [5] write array back to sheet (e.g. column D:E omitting title row)
   ws.Range("D2:E" & n + 1) = Results
 ' [6] clear memory
   Set ws = Nothing: Set dict = Nothing
End Sub