比较涂多色

liulang0808

Sub test()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheets("销").UsedRange
    For j = 2 To UBound(arr)
        If Not d.exists(arr(j, 3)) Then
            Set d(arr(j, 3)) = CreateObject("scripting.dictionary")
        End If
        If Not d(arr(j, 3)).exists(arr(j, 6)) Then
            Set d(arr(j, 3))(arr(j, 6)) = CreateObject("scripting.dictionary")
        End If
        d(arr(j, 3))(arr(j, 6))(j) = ""
    Next j
    arr = Sheets("财").UsedRange
    For j = 2 To UBound(arr)
        If d.exists(arr(j, 2)) Then
            If d(arr(j, 2)).exists(arr(j, 4)) Then
                If d(arr(j, 2))(arr(j, 4)).Count >= 1 Then
                    Cells(j, 1).Resize(1, 6).Interior.ColorIndex = 4
                    k = d(arr(j, 2))(arr(j, 4)).keys()(0)
                    Sheets("销").Cells(k, 1).Resize(1, 6).Interior.ColorIndex = 4
                    d(arr(j, 2))(arr(j, 4)).Remove k
                Else
                    Cells(j, 1).Resize(1, 6).Interior.ColorIndex = 44
                End If
            Else
                Cells(j, 1).Resize(1, 6).Interior.ColorIndex = 44
                For Each k In d(arr(j, 2)).keys
                    For Each kk In d(arr(j, 2))(k).keys
                        Sheets("销").Cells(kk, 1).Resize(1, 6).Interior.ColorIndex = 44
                    Next kk
                Next k
            End If
        End If
    Next j
End Sub

liulang0808

比较涂多色.zip (17.97 KB, 下载次数: 14)

2023-7-13 16:40 上传

点击文件名下载附件

于箱长

ykcbf1100 发表于 2023-7-13 16:37
等下我送你几个。

送我也只能当库存，送不去，感谢，感谢

ykcbf1100

于箱长 发表于 2023-7-13 16:41
送我也只能当库存，送不去，感谢，感谢

留着就好

xing_chen

笨鸟飞不高 发表于 2023-7-13 15:19
继续修改！

谢谢老师！运行如愿

xing_chen

于箱长 发表于 2023-7-13 15:54
差距啊，我这满满的一屏

谢谢老师！

xing_chen

cyq4896 发表于 2023-7-13 15:38
参与一下....

谢谢老师！运行如愿！

xing_chen

liulang0808 发表于 2023-7-13 16:40

谢谢老师！运行如愿！

xing_chen

liulang0808 发表于 2023-7-13 16:40

老师，就最后一朵发财花了。请笑纳

z865593849

练练手。。。。。。。。。