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

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

应该

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

Answer 2

试着改变你的代码如下：

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 3

这看起来草率和复杂。两者都是真实的，但它工作得很好。 注意！我总是推荐定义所有的​​，比如：范围，整数等等。最后一行存储到像LngRow这样的变量是最好的（不像整个App.WksFunc.COUNTA）。我也喜欢直接在单元上使用函数（如下面的SUMIFS）。因此，基于你的示例配置（列ABCD）：

Sub Test_Texas2014() 
Dim MySheet As Worksheet: Set MySheet = Sheets("Sheet1") 

'Clear the previous results before populating 
MySheet.Range("F:I").Clear 

'Step1 Find distinct values on column A and copy them on F 
For i = 1 To Application.WorksheetFunction.CountA(MySheet.Range("A:A")) 
    Row_PasteCount = Application.WorksheetFunction.CountA(MySheet.Range("F:F")) + 1 
    Set LookupID = MySheet.Range("A" & i) 
    Set LookupID_SearchRange = MySheet.Range("F:F") 
    Set CopyValueID_Paste = MySheet.Range("F" & Row_PasteCount) 
     If IsError(Application.Match(LookupID, LookupID_SearchRange, 0)) Then 
      LookupID.Copy 
      CopyValueID_Paste.PasteSpecial xlPasteValues 
     End If 
Next i 

'Step2 fill your values in columns G H I based on selection 
For j = 1 To Application.WorksheetFunction.CountA(MySheet.Range("F:F")) 
    Set ID = MySheet.Range("F" & j) 
    Set Index = MySheet.Range("G" & j) 
    Set AttributeX = MySheet.Range("H" & j) 
    Set SumX = MySheet.Range("I" & j) 
    For k = 1 To Application.WorksheetFunction.CountA(MySheet.Range("A:A")) 
     Set SearchedID = MySheet.Range("A" & k) 
     Set SearchedID_Index = MySheet.Range("B" & k) 
     Set SearchedID_AttributeX = MySheet.Range("C" & k) 
     Set SearchedID_SumX = MySheet.Range("D" & k) 
      If ID.Value = SearchedID.Value Then 
       Index.Value = SearchedID_Index.Value 
       AttributeX.Value = AttributeX.Value & ";" & SearchedID_AttributeX.Value 
       SumX.Value = SumX.Value + SearchedID_SumX.Value 
      End If 
     Next k 
    Next j 
End Sub 

'Although for the sum I would use something like: 
MySheet.Range("I1").Formula = "=SUMIFS(D:D,A:A,F1)" 
MySheet.Range("I1").Copy 
MySheet.Range("I2:I" & Application.WorksheetFunction.CountA(MySheet.Range("I:I"))).pasteSpecial xlPasteFormulas 
'Similar for the Index with a Vlookup or Index(Match()) 

Answer 4

由数字从塔d求和并建立从列C字符串连接与基于在列重复的值分号分隔符合并行A和B.

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 5

这会做你想做的。

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 

Answer 6

这是我的溶液

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