在单元格A1中组合具有相似值的行

Question

我在Excel中有两个文本列，大约有100k行。我需要结合列B中的文本，其中列A类似。所以从这个：

到此：

Answer 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

Answer 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

Answer 3

如果这是一次性项目，我会将A列和B列复制到separte表，按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（向上）。