Excel VBA - 在一个单元格中合并具有重复值的行并在另一个单元格中合并值
声明：本页面是StackOverFlow热门问题的中英对照翻译，遵循CC BY-SA 4.0协议，如果您需要使用它，必须同样遵循CC BY-SA许可，注明原文地址和作者信息，同时你必须将它归于原作者（不是我）：StackOverFlow
原文地址: http://stackoverflow.com/questions/20227196/
Warning: these are provided under cc-by-sa 4.0 license. You are free to use/share it, But you must attribute it to the original authors (not me):
StackOverFlow
Excel VBA - Combine rows with duplicate values in one cell and merge values in other cell
提问by Texas2014
I am trying to find duplicate values in one column and combine the values of a second column into one row. I also want to sum the values in a third column.
我试图在一列中查找重复值并将第二列的值合并为一行。我还想对第三列中的值求和。
For example:
例如：
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
Would become
会成为
A B C D
k 9 t;o;p;j 22
h 4 w;u;g;f 19
The code I have been using for the first part of this is
我在第一部分使用的代码是
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
(please forgive the indentation)
（请原谅缩进）
The problem that I am running into is that it will find the first pair of duplicates, but not all. So I get a result that looks like this:
我遇到的问题是它会找到第一对重复项，但不是全部。所以我得到一个看起来像这样的结果：
A B C D
k 9 t;o 12
k 9 p;j 10
h 4 w;u 8
h 4 g;f 11
Thoughts?
想法？
Thank you in advance.
先感谢您。
回答by Portland Runner
Try changing your code to this:
尝试将您的代码更改为：
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
Tested
已测试
EDIT
编辑
To make it a little easier to adjust to different column I added variables at the beginning to indicate which column do what. Note that column 2 (B) isn't used in the current logic.
为了更容易适应不同的列，我在开始时添加了变量来指示哪一列做什么。请注意，当前逻辑中未使用第 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
回答by Mak
Here is my solution
这是我的解决方案
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
回答by Takedasama
This looks sloppy and complicated. Both are true, but it works pretty fine.
Note!I always recommend to define all DIMs like: ranges, integers, etc. Storing the last row to a variable like LngRowis best (not like the whole App.WksFunc.COUNTA). I also like to use functions directly on cells where possible (like the SUMIFSex. below). Thus, based on your example configuration (columns ABCD):
这看起来很草率和复杂。两者都是正确的，但效果很好。
笔记！我总是建议定义所有的DIMs，如：范围、整数等。将最后一行存储到一个变量中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())
回答by Takedasama
Merging rows by summing the numbers from column D and building a string concatenation from column C with a semi-colon delimiter based upon duplicate values in columns A and B.
通过对 D 列中的数字求和并根据 A 列和 B 列中的重复值使用分号分隔符从 C 列构建字符串连接来合并行。
Before1:
之前1：
????????
?????????
Code:
代码：
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
After1:
之后1：
????????
?????????
1Some additional rows of data were added to the original posted data in order to demonstrate the sort.
1一些额外的数据行被添加到原始发布的数据中，以演示排序。
回答by ASH
This will do what you want.
这会做你想做的。
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
回答by bf2020
.Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 8)
.Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 8)
should be
应该
.Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 11)
.Cells(lngRow, 11) = .Cells(lngRow, 8) & "; " & .Cells(lngRow + 1, 11)
