合并具有重复值的行，如果不同，合并单元格 [英] Combine Rows with duplicate values, merge cells if different

问题描述

我有类似的问题
[组合行与重复值] [1]
Excel VBA - 在一个单元格中组合具有重复值的行，并在其他单元格中合并值

我有这种格式的数据（行排序）

I have data in this format (rows are sorted)

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）如果col 2和3匹配，那么如果col 4不同的合并col4，删除行。如果col 2,3,4匹配然后删除行，不要合并col 4

---

compare adjacent rows (say row 4 and 5) , if col 2 and 3 match then if col 4 different merge col4, delete row. if col 2,3,4 match then delete row, don't merge 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上的比较只能在非常简单的情况下工作。

Actual Output incorrect because when cells merge t3 will not match t3;t6, my comparison on col 4 will only work in very simple case only.

key ID  CH  Text
no  15  1   t2; t88
yes 15  2   t3; t3; t6

因此，我不得不添加这两个部分来拆分连接单元格，然后删除重复的

Therefore, I had to add these two sections to split the Concatenate cells and then remove duplicates

'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+如何？

Question: There must be much easier way to do this right than use three different methods? How about inserting new columns 5+ if col 4 items don't match?

注意：从excelforum中的用户nilem中找到重复的代码。

Note: Remove duplicates code was found from user nilem at excelforum.

编辑：如果Col 2和3匹配，Col 1将始终保持一致。如果解决方案容易得多，我们可以假设Col 1是空白的，忽略数据。

Col 1 will always be same if Col 2 and 3 match. If solution is much easier we can assume Col 1 is blank and ignore data.

我已经打印了图书查找表，需要转换为将用于使用1960年代语言的设备，命令非常有限。我试图预定格这个数据，所以我只需要搜索一行，所有的信息。

I have printed book lookup table and need to convert to a simple format that will be used in equipment that use a 1960's language which has very limited commands. I am trying to preformat this data so I only need to search for one row that has all info.

Col D最终输出可以在带有分隔符的col D或D-K（只有8最大Ref）中，因为我将解析在其他机器上使用。无论什么方法都比较容易

Col D final output can be in col D with delimiter or into col D-K (only 8 max Ref) because I will parse to use on other machine. Whatever method is easier.

推荐答案

变体使用字典下方

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

之前

after

这篇关于合并具有重复值的行，如果不同，合并单元格的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！