Question

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

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

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

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

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

即

提前感谢您的帮助。

Answer 1

这适用于andy：

使用数组公式：

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

必须使用 Ctrl + Shift + 输入输入

数组公式，而不仅仅是 Enter 键。如果这样做正确，公式将在公式栏中以大括号显示。

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

修改＃1：

自动执行此操作：

将列 A 复制到 C
列
使用Excel的RemoveDuplicates功能创建唯一名称列表

将数组公式应用于该唯一列表的每个成员。

修改＃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

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

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

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

3 个答案: