Excel VBA - 在一个单元格中组合具有重复值的行，并在其他单元格中合并值

Question

我试图在一列中找到重复值，并将第二列的值合并为一行。我还想在第三列中对值进行求和。

例如：

A    B    C    D
h    4    w    3
h    4    u    5
h    4    g    7
h    4    f    4
k    9    t    6
k    9    o    6
k    9    p    9
k    9    j    1

会变成

A    B    C        D
k    9    t;o;p;j  22
h    4    w;u;g;f  19

我在第一部分使用的代码是

 Sub mergeCategoryValues()
Dim lngRow As Long

With ActiveSheet

lngRow = .Cells(65536, 1).End(xlUp).Row

.Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes 
Do

    If .Cells(lngRow, 9) = .Cells(lngRow + 1, 9) Then
        .Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 8)
        .Rows(lngRow +1).Delete
    End If

    lngRow = lngRow - 1

Loop Until lngRow < 2

End With

End Sub

（请原谅缩进）

我遇到的问题是它会找到第一对副本，但不是全部。所以我得到一个看起来像这样的结果：

A    B    C    D
k    9    t;o  12
k    9    p;j  10   
h    4    w;u  8
h    4    g;f  11

思考？

提前谢谢。

Answer 1

尝试将代码更改为：

Sub mergeCategoryValues()
    Dim lngRow As Long

    With ActiveSheet
        lngRow = .Cells(65536, 1).End(xlUp).Row
        .Cells(1).CurrentRegion.Sort key1:=.Cells(1), Header:=xlYes

        Do
            If .Cells(lngRow, 1) = .Cells(lngRow - 1, 1) Then
                .Cells(lngRow - 1, 3) = .Cells(lngRow - 1, 3) & "; " & .Cells(lngRow, 3)
                .Cells(lngRow - 1, 4) = .Cells(lngRow - 1, 4) + .Cells(lngRow, 4)
                .Rows(lngRow).Delete
            End If

            lngRow = lngRow - 1
        Loop Until lngRow = 1
    End With
End Sub

---

测试

---

修改

为了让它更容易调整到不同的列，我在开头添加了变量，以指示哪个列做什么。请注意，第2列（B）未在当前逻辑中使用。

Sub mergeCategoryValues()
    Dim lngRow As Long

    With ActiveSheet
        Dim columnToMatch As Integer: columnToMatch = 1
        Dim columnToConcatenate As Integer: columnToConcatenate = 3
        Dim columnToSum As Integer: columnToSum = 4

        lngRow = .Cells(65536, columnToMatch).End(xlUp).Row
        .Cells(columnToMatch).CurrentRegion.Sort key1:=.Cells(columnToMatch), Header:=xlYes

        Do
            If .Cells(lngRow, columnToMatch) = .Cells(lngRow - 1, columnToMatch) Then
                .Cells(lngRow - 1, columnToConcatenate) = .Cells(lngRow - 1, columnToConcatenate) & "; " & .Cells(lngRow, columnToConcatenate)
                .Cells(lngRow - 1, columnToSum) = .Cells(lngRow - 1, columnToSum) + .Cells(lngRow, columnToSum)
                .Rows(lngRow).Delete
            End If

            lngRow = lngRow - 1
        Loop Until lngRow = 1
    End With
End Sub

Answer 2

这看起来很草率和复杂。两者都是真的，但它工作得很好。 注意！我总是建议定义所有DIM，如：范围，整数等。将最后一行存储到LngRow之类的变量是最好的（不像整个{ {1}}）。我也喜欢在可能的情况下直接在单元格上使用函数（如下面的App.WksFunc.COUNTA ex。）。因此，基于您的示例配置（列ABCD）：

SUMIFS

Answer 3

通过对D列中的数字求和并使用基于A和B列中的重复值的分号分隔符构建C列中的字符串并置来合并行。

Before¹：

代码：

Sub merge_A_to_D_data()
    Dim rw As Long, lr As Long, str As String, dbl As Double

    Application.ScreenUpdating = False
    With ActiveSheet.Cells(1, 1).CurrentRegion
        .Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
                    Key2:=.Columns(2), Order2:=xlAscending, _
                    Orientation:=xlTopToBottom, Header:=xlYes
        lr = .Rows.Count
        For rw = .Rows.Count To 2 Step -1
            If .Cells(rw, 1).Value2 <> .Cells(rw - 1, 1).Value2 And _
               .Cells(rw, 2).Value2 <> .Cells(rw - 1, 2).Value2 And rw < lr Then
                .Cells(rw, 4) = Application.Sum(.Range(.Cells(rw, 4), .Cells(lr, 4)))
                .Cells(rw, 3) = Join(Application.Transpose(.Range(.Cells(rw, 3), .Cells(lr, 3))), Chr(59))
                .Cells(rw + 1, 1).Resize(lr - rw, 1).EntireRow.Delete
                lr = rw - 1
            End If
        Next rw
    End With
    Application.ScreenUpdating = True
End Sub

After¹：

¹_{为了证明排序，我们在原始发布数据中添加了一些额外的数据行。}

Answer 4

这是我的解决方案

Sub MyCombine()
Dim i As Integer
ActiveSheet.Sort.SortFields.Add Key:=Range("A:A"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveSheet.Sort
    .SetRange Range("A:D")
    .Header = xlYes
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlStroke
    .Apply
End With

i = 2

Do Until Len(Cells(i, 1).Value) = 0
    If Cells(i, 1).Value = Cells(i + 1, 1).Value Then
        Cells(i, 3).Value = Cells(i, 3).Value & ";" & Cells(i + 1, 3).Value
        Cells(i, 4).Value = Cells(i, 4).Value + Cells(i + 1, 4).Value
        Rows(i + 1).Delete
    Else
        i = i + 1
    End If
Loop    
End Sub

Answer 5

.Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 8)

应该是

.Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 11)

Answer 6

这将做你想要的。

Sub Macro()
Dim lngRow As Long
For lngRow = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row To 2 Step -1
If StrComp(Range("B" & lngRow), Range("B" & lngRow - 1), vbTextCompare) = 0 Then
If Range("C" & lngRow) <> "" Then
Range("C" & lngRow - 1) = Range("C" & lngRow - 1) & ";" & Range("C" & lngRow)
Range("D" & lngRow - 1) = Range("D" & lngRow - 1) + Range("D" & lngRow)
End If
Rows(lngRow).Delete
End If
Next
End Sub