Excel VBA – 将具有重复值的行组合到一个单元格中,并合并其他单元格中的值

我想在一列中find重复值,并将第二列的值组合成一行。 我也想总结第三栏的值。

例如:

ABCD 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 

会成为

 ABCD 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 

(请原谅缩进)

我遇到的问题是,它会find第一对重复,但不是全部。 所以我得到的结果是这样的:

 ABCD k 9 t;o 12 k 9 p;j 10 h 4 w;u 8 h 4 g;f 11 

思考?

先谢谢你。

尝试将您的代码更改为:

 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 

经testing

在这里输入图像描述


编辑

为了使它更容易调整到不同的列,我在开始时添加了variables,以指示哪个列做了什么。 请注意,第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 

这看起来马虎而复杂。 两者都是真实的,但它工作得很好。 注意! 我总是推荐定义所有的LngRow ,如:范围,整数等。最后一行存储到像LngRow这样的variables是最好的(不像整个App.WksFunc.COUNTA )。 我也喜欢直接在单元格上使用函数(如下面的SUMIFS )。 因此, 根据您的示例configuration(列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 GHI 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()) 

通过汇总列D中的数字合并行,并根据列A和B中的重复值使用分号分隔符构build列C中的string连接。

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¹:

合并后的数据

¹ 一些额外的数据行被添加到原始的发布数据,以演示sorting。

这是我的解决scheme

 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 

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

应该

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

这将做你想要的。

 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