求修改对比的代码

lagos

以两列为一组，同其他的组比较，如果相同的，就在第一行标注相同的数字，且不相同的数字不能相同。详情请见附件： 求修改代码.rar (97.47 KB, 下载次数: 8)

2023-6-5 09:24 上传

点击文件名下载附件

3190496160

3190496160

颜色系列是从0-56，所以当k等于57的时候肯定就下标越界了

lagos

3190496160 发表于 2023-6-5 10:01
颜色系列是从0-56，所以当k等于57的时候肯定就下标越界了

多谢大神找出原因，能帮忙更改成用数字标注的吗？这样就不受颜色种类限制了。

lkqsmxw

Sub TEST2()
    Dim ar, br(), cr, i&, j&, k&, kk&, n&, r&, vKey, dic As Object, strJoin$
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")

    With Range("C2", Cells(Rows.Count, "AUU").End(xlUp))
        ar = .Value
        .Interior.Color = xlNone
        For j = 1 To UBound(ar, 2) Step 3
            r = r + 1
            ReDim Preserve br(1 To r)
            br(r) = .Cells(1, j).Resize(UBound(ar), 2)
            strJoin = ""
            For i = 1 To UBound(br(r))
                For k = 1 To UBound(br(r), 2)
                    strJoin = strJoin & br(r)(i, k)
                Next k
            Next i
            dic(strJoin) = dic(strJoin) & " " & r
        Next j
        k = 6
        kk = 3
        n = 0
        For Each vKey In dic.keys
            cr = Split(dic(vKey))
            If UBound(cr) > 1 Then
                If k < 56 Then k = k + 1 Else k = 6
                If kk < 56 Then kk = kk + 1 Else n = n + 1: kk = 3 + n
                For i = 1 To UBound(cr)
                    .Cells(1, (cr(i) - 1) * 3 + 1).Resize(UBound(ar) / 2, 2).Interior.ColorIndex = k
                    .Cells(UBound(ar) / 2 + 1, (cr(i) - 1) * 3 + 1).Resize(UBound(ar) / 2, 2).Interior.ColorIndex = kk
                Next
            End If
        Next
    End With
    Application.ScreenUpdating = True
    Beep
End Sub

lkqsmxw

kkkkkkkkkkkkkkkkkkkkkkkk

lagos

lkqsmxw 发表于 2023-6-5 10:37
kkkkkkkkkkkkkkkkkkkkkkkk

多谢大神，看起来怪怪的，咱是咋想到要用颜色来标注重复的？眼都看花了。只能花着眼通过一个一个的比对颜色来找重复组了。还是谢谢大神解决颜色的问题

gwjkkkkk

lagos 发表于 2023-6-5 10:24
多谢大神找出原因，能帮忙更改成用数字标注的吗？这样就不受颜色种类限制了。

原来那个还是我写的吧，代码简单修改一下就可以了，请参考附件。。。