在单元格 A1 中合并具有相似值的行答案

【问题标题】：Combining rows with similar value in cell A1在单元格 A1 中合并具有相似值的行
【发布时间】：2015-10-23 10:58:43
【问题描述】：

我在 Excel 中有两个文本列，大约 100k 行。我需要将 A 列相似的 B 列中的文本组合起来。所以从这里：

到这里：

【问题讨论】：

请告诉我们您尝试过的代码。
我尝试了一个搜索列然后更新的公式。问题是行太多，A 列中的一些数据可能少至 2 或多至 27。如果公式是要走的路，我不赞成。
如果您希望所有数据进入 B 列，我很确定您需要 VBA。如果您可以在 B、C 和 D 列（等）中有不同的匹配项（“apple”、“tree”、“water”），那么可能有一个公式可以做到这一点。您也可以将它们放在 C、D、E 等中，然后连接到 B。到目前为止，您尝试过什么公式？
如果您迫切需要公式解决方案，请参阅此处的讨论：stackoverflow.com/q/33112330/5090027 简而言之 - 没有简单的方法，但可以使用辅助列。
您使用什么规则从 To 表中的 B1 中省略 From 表中的 B1 中的 TREE。如果你把所有的词组合起来，B1不应该是APPLE TREE TREE WATER吗？

【解决方案1】：

这可能不是最有效的方法，但确实有效。

Sub CellStringCombine()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim intNumRange As Long
Dim strNewName As String
Dim x As Long
Dim y As Long
Dim intRowDiff As Long
Dim intRow As Long

intNumRange = WorksheetFunction.CountA(Range("A:A"))

x = 1

'start looping through rows
Do While Cells(x, "A") <> ""
'set the placeholder variable, offset to the next row
    y = x + 1
'if the current row is equal to the next one, find out how far it's equal
    Do While Cells(x, "A") = Cells(y, "A")
        y = y + 1
    Loop
    intRowDiff = y - x

'check to see if the next row isn't equal. go to next row if yes.

    If intRowDiff = 1 Then
        GoTo NextCell
    End If

'Loop through the range identified
    For intRow = x To x + intRowDiff - 1

'If it's the first round, only take the name
        If intRow = x Then
            strNewName = Cells(intRow, "B")
'If it's after the first round, have it equal itself and put a space
        ElseIf intRow > x Then
            strNewName = strNewName + " " + Cells(intRow, "B")
        End If
    Next intRow

'Delete the identified range except the first row
    Range("A" & x + 1, "B" & y - 1).EntireRow.Delete

'Overwrite the text in column B
    Cells(x, "B") = strNewName

NextCell:
x = x + 1

Loop

Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub

【讨论】：

【解决方案2】：

只是因为我想看看我是否可以使用数组来做到这一点。

Sub JSA()
Dim i&, t&
Dim StrArr() As String
Dim ows As Worksheet
Dim tws As Worksheet

ReDim StrArr(0)

Set ows = ActiveWorkbook.Worksheets("Sheet2")
Set tws = ActiveWorkbook.Worksheets("Sheet3")

With ows
    For i = 1 To .Range("A" & .Rows.count).End(xlUp).Row
        If i = 1 Then
            StrArr(0) = .Cells(i, 1) & "|"
        ElseIf .Cells(i, 1) <> .Cells(i - 1, 1) Then
            ReDim Preserve StrArr(UBound(StrArr) + 1) As String
            StrArr(UBound(StrArr)) = .Cells(i, 1) & "|"
        End If
        StrArr(UBound(StrArr)) = StrArr(UBound(StrArr)) & .Cells(i, 2) & " "
    Next i
End With

For t = 1 To UBound(StrArr) + 1
    tws.Cells(t, 1) = Split(StrArr(t - 1), "|")(0)
    tws.Cells(t, 2) = Trim(Split(StrArr(t - 1), "|")(1))
Next t
End Sub

【讨论】：

【解决方案3】：

如果这是一个一次性项目，我会将 A 列和 B 列复制到单独的表中，然后按 A 列对其进行排序。

In column C (Row2) a formula "IIf(A2=A1;0;1)"
In column D (Row2) a formula "IIf(C1=1;B2;B1 & " " & B2)"

然后填充到最后一行。将整个内容（仅限值）复制到不同的表中并再次排序（按 C（向下）和 A（向上）。

【讨论】：