如何在 Excel 2010 中添加多行内容到一个单元格，并按第三行分组

Question

我试图将不同行中的多个名称放入一行中的一个单元格中，但按另一列中的值对其进行分组。我还需要名称列表之间有换行符，而不是逗号分隔的列表。我不确定这是否可行。我已经获得了一些我需要的部分，例如 =CONCATENATE(TRANSPOSE(B2:B19)) 用于将数据放入一个单元格，以及 char(10) 用于添加换行符，但我无法将它们组合在一起以获得我想要的结果。

目前数据如下：

我想要的是：

即使是 VBA 解决方案也可以 - 尽管它不是我的强项。;) 我需要这样的数据来用于 Word 邮件合并。

还请注意，电子表格中还有几列数据。为了简单起见，我省略了它们。

Answer 1

我建议一个需要一点 VBA 的解决方案。

在此示例中，样本数据位于 B2:C10 中。保留 E1 作为标题单元格，在 E2 中输入以下公式，然后在公式栏中按 CTRL + SHIFT + ENTER 以创建数组公式。现在公式应括在花括号中，以表明它是一个数组公式。

=IFERROR(INDEX($B$2:$B$10, MATCH(0, COUNTIF(E$1:$E1, $B$2:$B$10), 0),1),"") 

将其向下拖动直到空白。这首先会从 B2:B10 的组中创建一个唯一值列表。请注意，无论您将此公式放在哪里，它上方至少应有一个单元格可供引用。在这种情况下，E1 是公式从 E2 开始的。

我们将使用一个名为 TEXTJOIN 的函数。然而，在大多数版本的 Excel 中，此功能不可用。如果您使用的是 Office 365 版本的 Excel 2016，则可以使用此功能。如果不可用，请在 VBA 中使用下面的 UDF（用户定义函数）来复制相同的功能。

按 ALT + F11 访问 VBA 编辑器。从插入菜单插入一个模块。将以下 UDF 放入其中。

Function TEXTJOIN1(delimiter As String, ignore_empty As Boolean, ParamArray cell_ar() As Variant)
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

现在回到 Excel 工作表，我们将使用此函数作为公式中的 UDF。在 F2 中输入以下公式，然后按 CTRL + SHIFT + ENTER 创建数组公式。

=IFERROR(TEXTJOIN1(CHAR(10),TRUE,IF($B$2:$B$10=E2,$C$2:$C$10,"")),"")

将其向下拖动到所需的行。等一下，这将创建一个按组由 Char(10) 连接的名称列表，但要看到正确的效果，您需要在目标单元格上启用自动换行。您可以从 Excel 中的“设置单元格格式”选项手动执行此操作，也可以使用下面的简单宏为您执行此操作。只需在开头指定范围即可。在此示例中，它是 E2:F4。

按 ALT + F11 访问 VBA 编辑器。从“插入”菜单插入一个模块，并将以下代码粘贴到其中。这将创建一个名为 Format1 的宏

子格式1()

    Range("E2:F4").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlTop
        .WrapText = True
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
End Sub

返回 Excel 工作表按 ALT + F8 访问宏对话框并运行 Format1。

在您这边测试此解决方案，如果有任何问题请告知我。

Answer 2

发布之后，在看到其他答案之前，我和一位同事一起工作并且我们让它工作起来。

首先按组排序，然后按名称排序。

然后我们添加了一个列，用于检查名称是否已添加（有重复项）以及组是否相同或不同。如果该名称尚未添加且仍是同一组，则它会将新名称连接到上面单元格的列表中，使用：

=IF(B2=B1,C1,IF(A2=A1,CONCATENATE(C1,CHAR(10),B2),B2))

在另一列中，我们创建了组中姓名的连续反向计数。

=IF(A2=A1,D1-1,COUNTIF(A:A,A2))

得到了这个：

然后我们只需用“1”过滤 D 列：

Answer 3

Private Sub MergeDuplicates()


Dim Rng As Range, xCell As Range
Dim xRows As Integer


xTitleId = "Merge Duplicates"

Set WorkRng = Application.Selection
Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)

Application.ScreenUpdating = False
Application.DisplayAlerts = False

xRows = WorkRng.Rows.count

For Each Rng In WorkRng.Columns
    For i = 1 To xRows - 1
        For j = i + 1 To xRows
            If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
                Exit For
            End If
        Next
        WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge
        i = j - 1

    Next
Next

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

注意： 将此代码作为模块插入并返回工作表以运行它，在出现输入框时选择所需的数据范围，然后单击确定完成。