将事物分组到一起的功能？

Question

大家好，我朋友的父亲问我是否知道如何在 Excel 上完成一项任务，但我不知道，所以为了帮助他，我想我会在这里问。这就是他正在尝试做的事情。

他有一张类似于这样的 Excel 表：

    A          B 
1   House 1    card 1 
2   House 1    card 2
3   House 1    card 3 
4   House 1    card 4 

大约有 500 个条目与此类似。因此，无需手动取出每张卡片并将其移动到第一行，然后删除其他 House 1 条目，是否有某种功能可以将具有相同名称的任何内容及其后续条目分组在一起。从视觉上看，他希望将前面的示例变成这样：

  A        B       C       D       E
1 House 1  card 1  card 2  card 3  card 4

谢谢任何人提供的帮助。

Answer 1

如果您的列表按 A 列排序，那么此方法将为您提供所需的内容。

将 A 列中的列表复制到另一列。

然后使用删除重复项来获取唯一列表：

然后在第一个项目旁边的第一个单元格中输入：

=IF(COLUMN(A:A)>COUNTIF($A:$A,$E1),"",INDEX($B:$B,MATCH($E1,$A:$A,0)+COLUMN(A:A)-1))

然后复制最多包含最多项目的列。然后复制到列表底部。

然后将值复制并粘贴到新工作表或其自身中。

---

如果您想现场执行此操作；我为另一个不愿透露姓名的网站编写了此代码。它将在现场快速完成您想要的操作：

Sub FOOO()
Dim inArr() As Variant
Dim outArr() As Variant
Dim ws As Worksheet
Dim cntrw As Long
Dim cntclm As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim rng As Range

Set ws = ActiveSheet

With ws
    Set rng = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
    'find the max number column that will be needed in the output
    cntclm = ws.Evaluate("MAX(COUNTIF(" & rng.Address & "," & rng.Address & "))") + 1
    'find the number of rows that will be needed in the output.
    cntrw = ws.Evaluate("SUM(1/COUNTIF(" & rng.Address & "," & rng.Address & "))")
    'put the existing data into an an array
    inArr = rng.Resize(, 2).Value
    'resize output array to the extents needed
    ReDim outArr(1 To cntrw, 1 To cntclm)
    'put the first value in the first spot in the output
    outArr(1, 1) = inArr(1, 1)
    outArr(1, 2) = inArr(1, 2)
    'these are counters to keep track of which slot the data should go.
    j = 3
    k = 1
    'loop through the existing data rows
    For i = 2 To UBound(inArr, 1)
        'test whether the data in A has changed or not.
        If inArr(i, 1) = inArr(i - 1, 1) Then
            'if not put the value in B in the next slot and iterate to the next column
            outArr(k, j) = inArr(i, 2)
            j = j + 1
        Else
            'if change start a new line in the outarr and fill the first two slots
            k = k + 1
            j = 3
            outArr(k, 1) = inArr(i, 1)
            outArr(k, 2) = inArr(i, 2)
        End If
    Next i
    'remove old data
    .Range("A:B").Clear
    'place new data in its place.
    .Range("A1").Resize(UBound(outArr, 1), UBound(outArr, 2)).Value = outArr
End With
End Sub

前：

后：

笔记：两种方法都要求对 A 列进行排序。