将行与重复值组合，合并单元格（如果不同）
我有类似的问题[结合行与重复值] [1] Excel VBA – 合并具有重复值的行在一个单元格中，并合并其他单元格中的值
我有这种格式的数据（行sorting）
Pub ID CH Ref no 15 1 t2 no 15 1 t88 yes 15 2 t3 yes 15 2 t3 yes 15 2 t6 比较相邻的行（比如第4行和第5行），如果第2列和第3列匹配，则第4列不同的合并col4，删除行。 如果col 2,3,4匹配然后删除行，不要合并col 4
期望的输出
key ID CH Text no 15 1 t2 t88 yes 15 2 t3 t6
这第一个代码段不起作用
Sub mergeCategoryValues() Dim lngRow As Long With ActiveSheet Dim columnToMatch1 As Integer: columnToMatch1 = 2 Dim columnToMatch2 As Integer: columnToMatch2 = 3 Dim columnToConcatenate As Integer: columnToConcatenate = 4 lngRow = .Cells(65536, columnToMatch1).End(xlUp).row .Cells(columnToMatch1).CurrentRegion.Sort key1:=.Cells(columnToMatch1), Header:=xlYes .Cells(columnToMatch2).CurrentRegion.Sort key1:=.Cells(columnToMatch2), Header:=xlYes Do If .Cells(lngRow, columnToMatch1) = .Cells(lngRow - 1, columnToMatch1) Then 'check col 2 row lngRow, lngRow-1 If .Cells(lngRow, columnToMatch2) = .Cells(lngRow - 1, columnToMatch2) Then 'check col 3 row lngRow, lngRow-1 If .Cells(lngRow - 1, columnToConcatenate) = .Cells(lngRow, columnToConcatenate) Then Else .Cells(lngRow - 1, columnToConcatenate) = .Cells(lngRow - 1, columnToConcatenate) & "; " & .Cells(lngRow, columnToConcatenate) End If .Rows(lngRow).Delete End If End If lngRow = lngRow - 1 Loop Until lngRow = 1 End With
实际输出不正确，因为当单元格合并t3不会匹配t3; t6时，我在col 4上的比较只能在非常简单的情况下工作。
实际产出
key ID CH Text no 15 1 t2; t88 yes 15 2 t3; t3; t6
因此，我不得不添加这两个部分拆分连接单元格，然后删除重复
'split cell in Col d to col e+ delimited by ; With Range("D2:D6", Range("D" & Rows.Count).End(xlUp)) .Replace ";", " ", xlPart .TextToColumns other:=True End With 'remove duplicates in each row Dim x, y(), i&, j&, k&, s$ With ActiveSheet.UsedRange x = .Value: ReDim y(1 To UBound(x, 1), 1 To UBound(x, 2)) For i = 1 To UBound(x) For j = 1 To UBound(x, 2) If Len(x(i, j)) Then If InStr(s & "|", "|" & x(i, j) & "|") = 0 Then _ s = s & "|" & x(i, j): k = k + 1: y(i, k) = x(i, j) End If Next j: s = vbNullString: k = 0 Next i .Value = y() End With End Sub
额外的代码输出是
Pub ID CH Ref no 15 1 t2 t88 yes 15 2 t3 t6
问题：使用三种不同的方法必须有更简单的方法来做到这一点吗？ 如果col 4项不匹配，如何插入新的列5+？
注意：删除重复的代码是在excelforum上从用户nilem中find的。
编辑：如果第二列和第三列相符，列1将始终相同。 如果解决scheme更容易，我们可以假设列1是空白的，忽略数据。
我已经打印书籍查找表，并需要转换为一个简单的格式，将使用在1960年的语言，其中有非常有限的命令的设备中使用。 我试图预先格式化这个数据，所以我只需要search一个有所有信息的行。
Col D最终输出可以在带分隔符的col D中或col DK中（最多只有8个Ref），因为我将在其他机器上parsing使用。 无论哪种方法更简单。
删除行的规范实践是从底部开始，向顶部工作。 以这种方式，行不会被跳过。 这里的诀窍是find当前位置上方与列B和C匹配的行，并在移除行之前连接来自列D的string。 有几个很好的工作表公式可以获得两列匹配的行号。 将其中一个用于application.Evaluate实践。评估似乎是从D列中收集值的最方便的方法。
Sub dedupe_and_collect() Dim rw As Long, mr As Long, wsn As String With ActiveSheet '<- set this worksheet reference properly! wsn = .Name With .Cells(1, 1).CurrentRegion .RemoveDuplicates Columns:=Array(2, 3, 4), Header:=xlYes End With With .Cells(1, 1).CurrentRegion 'redefinition after duplicate removal For rw = .Rows.Count To 2 Step -1 'walk backwards when deleting rows If Application.CountIfs(.Columns(2), .Cells(rw, 2).Value, .Columns(3), .Cells(rw, 3).Value) > 1 Then mr = Application.Evaluate("MIN(INDEX(ROW(1:" & rw & ")+(('" & wsn & "'!B1:B" & rw & "<>'" & wsn & "'!B" & rw & ")+('" & wsn & "'!C1:C" & rw & "<>'" & wsn & "'!C" & rw & "))*1E+99, , ))") 'concatenate column D '.Cells(mr, 4) = .Cells(mr, 4).Value & "; " & .Cells(rw, 4).Value 'next free column from column D .Cells(mr, Columns.Count).End(xlToLeft).Offset(0, 1) = .Cells(rw, 4).Value .Rows(rw).EntireRow.Delete End If Next rw End With End With End Sub
三列匹配logging的删除是通过VBA等同于“date”►“数据工具”►“删除重复”命令完成的。 这只考虑列B，C和D，并删除较低的重复项（保留最接近第1行的项）。 如果A列在这方面很重要，则必须增加额外的编码。
目前还不清楚是否需要将列D作为分隔string或单独的单元格作为最终结果。 你能澄清吗？
正如我上面写的，我会遍历数据并收集到用户定义的对象中的东西。 这种方法不需要对数据进行sorting， 重复的REF将被省略。
用户定义对象的一个优点是它使得debugging更容易，因为你可以更清楚地看到你所做的事情。
如果使用相同的键，我们将使用Collection对象的属性来组合ID和CH相同的每一行。
至于将单个单元格中的Ref与分隔符组合起来，还是将D：K中的单个单元格合并，可以简单地完成。 我select分离成列，但将其改为合并为一列将是微不足道的。
插入类模块后，您必须重命名它： cID_CH
你会注意到我把结果放在一个单独的工作表上。 你可以覆盖原始数据，但我会build议反对的。
类模块
Option Explicit Private pID As Long Private pCH As Long Private pPUB As String Private pREF As String Private pcolREF As Collection Public Property Get ID() As Long ID = pID End Property Public Property Let ID(Value As Long) pID = Value End Property Public Property Get CH() As Long CH = pCH End Property Public Property Let CH(Value As Long) pCH = Value End Property Public Property Get PUB() As String PUB = pPUB End Property Public Property Let PUB(Value As String) pPUB = Value End Property Public Property Get REF() As String REF = pREF End Property Public Property Let REF(Value As String) pREF = Value End Property Public Property Get colREF() As Collection Set colREF = pcolREF End Property Public Sub ADD(refVAL As String) On Error Resume Next pcolREF.ADD refVAL, refVAL On Error GoTo 0 End Sub Private Sub Class_Initialize() Set pcolREF = New Collection End Sub
常规模块
Option Explicit Sub CombineDUPS() Dim wsSRC As Worksheet, wsRES As Worksheet Dim vSRC As Variant, vRES() As Variant, rRES As Range Dim cI As cID_CH, colI As Collection Dim I As Long, J As Long Dim S As String 'Set source and results worksheets and results range Set wsSRC = Worksheets("sheet1") Set wsRES = Worksheets("sheet2") Set rRES = wsRES.Cells(1, 1) 'Get Source data With wsSRC vSRC = .Range("A2", .Cells(.Rows.Count, "D").End(xlUp)) End With 'Collect and combine data Set colI = New Collection On Error Resume Next For I = 1 To UBound(vSRC, 1) Set cI = New cID_CH With cI .PUB = vSRC(I, 1) .ID = vSRC(I, 2) .CH = vSRC(I, 3) .REF = vSRC(I, 4) .ADD .REF S = CStr(.ID & "|" & .CH) colI.ADD cI, S If Err.Number = 457 Then Err.Clear colI(S).ADD .REF ElseIf Err.Number <> 0 Then Debug.Print Err.Number, Err.Description Stop End If End With Next I On Error GoTo 0 'Create and populate Results Array ReDim vRES(0 To colI.Count, 1 To 11) 'Header row vRES(0, 1) = "Pub" vRES(0, 2) = "ID" vRES(0, 3) = "CH" vRES(0, 4) = "Ref" 'populate array For I = 1 To colI.Count With colI(I) vRES(I, 1) = .PUB vRES(I, 2) = .ID vRES(I, 3) = .CH For J = 1 To .colREF.Count vRES(I, J + 3) = .colREF(J) Next J End With Next I 'Write the results to the worksheet Set rRES = rRES.Resize(UBound(vRES, 1) + 1, UBound(vRES, 2)) With rRES .EntireColumn.Clear .Value = vRES With .Rows(1) .Font.Bold = True .HorizontalAlignment = xlCenter Range(.Cells(4), .Cells(11)).HorizontalAlignment = xlCenterAcrossSelection End With .EntireColumn.AutoFit End With End Sub
原版的
处理结果
变体使用下面的字典
Sub test() Dim Dic As Object: Set Dic = CreateObject("Scripting.Dictionary") Dic.Comparemode = vbTextCompare Dim Cl As Range, x$, y$, i&, Key As Variant For Each Cl In Range("B2:B" & Cells(Rows.Count, "B").End(xlUp).Row) x = Cl.Value & "|" & Cl.Offset(, 1).Value y = Cl.Offset(, 2).Value If Not Dic.exists(x) Then Dic.Add x, Cl.Offset(, -1).Value & "|" & y & "|" ElseIf Dic.exists(x) And Not LCase(Dic(x)) Like "*|" & LCase(y) & "|*" Then Dic(x) = Dic(x) & "|" & y & "|" End If Next Cl Range("A2:D" & Cells(Rows.Count, "B").End(xlUp).Row).ClearContents i = 2 For Each Key In Dic Cells(i, "A") = Split(Dic(Key), "|")(0) Range(Cells(i, "B"), Cells(i, "C")) = Split(Key, "|") Cells(i, "D") = Replace(Split(Replace(Dic(Key), "||", ";"), "|")(1), ":", ";") i = i + 1 Next Key Set Dic = Nothing End Sub
之前
后
