vba - 合并具有重复值的行，如果不同则合并单元格

Question

我有类似的问题[合并具有重复值的行][1] Excel VBA - Combine rows with duplicate values in one cell and merge values in other cell

我有这种格式的数据(行已排序)

<小时/>

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 列不同，则合并第 4 行，删除行。如果第 2,3,4 列匹配则删除行，不合并第 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 将与 t3;t6 不匹配，我对第 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

问题:一定有比使用三种不同方法更简单的方法来正确执行此操作吗？如果第 4 列项目不匹配，插入新列 5+ 怎么样？

注意:删除重复代码是从 excelforum 的用户 nilem 处找到的。

编辑:如果第 2 列和第 3 列匹配，第 1 列将始终相同。如果解决方案更容易，我们可以假设第 1 列为空白并忽略数据。

我有打印的书籍查找表，需要转换为一种简单的格式，该格式将在使用 1960 年代语言的设备中使用，该语言的命令非常有限。我正在尝试预先格式化这些数据，因此我只需要搜索包含所有信息的一行。

Col D 最终输出可以在带有分隔符的 col D 中，也可以在 col D-K 中(最大只有 8 个引用)，因为我将解析以在其他机器上使用。无论哪种方法都比较容易。

Answer 1

删除行的规范做法是从底部开始并向顶部进行。以这种方式，不会跳过行。这里的技巧是找到当前位置上方与 B 列和 C 列匹配的行，并在删除该行之前连接 D 列中的字符串。有几个很好的工作表公式可以获取两列匹配的行号。使用 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

删除三列匹配上的记录是使用“日期”>“数据工具”>“删除重复项”命令的 VBA 等效命令完成的。这仅考虑 B、C 和 D 列，并删除较低的重复项(保留最接近第 1 行的重复项)。如果 A 列在这方面很重要，则必须添加额外的编码。

我不清楚您是否希望 D 列作为分隔字符串或单独的单元格作为最终结果。你能澄清一下吗？