[已解决]请教：多条件判断取值并标注颜色

海水鱼lw

请看附件： 请教：多条件判断取值并标注颜色.rar (29.2 KB, 下载次数: 6)

2023-11-9 11:31 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

哥儿-

2023-11-9 18:39

Sub test()
    Dim i%, j%, k%, arr, brr, dic As Object, dic2 As Object
    arr = Range("A7").CurrentRegion
    brr = Range("H6").CurrentRegion
    Set dic = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")
    ReDim crr(1 To UBound(brr, 1), 1 To UBound(brr, 2))
    For i = 2 To UBound(brr, 1) - 1
        For k = 1 To UBound(arr, 2)
            dic(arr(i - 1, k)) = dic(arr(i - 1, k)) + 1
            dic2(arr(i, k)) = dic2(arr(i, k)) + 1
        Next k
        For j = 1 To UBound(brr, 2)
            If Not dic.exists(brr(1, j)) Then
                If brr(i, j) = "" And brr(i + 1, j) = "" Then crr(i, j) = brr(1, j)
                If dic2(crr(i, j)) = 1 Then Cells(i + 20, j + 41).Interior.ColorIndex = 43
            End If
        Next j
        dic.RemoveAll
        dic2.RemoveAll
    Next i
     Range("AP21").Resize(UBound(crr, 1), UBound(crr, 2)) = crr
     
End Sub

跳转到最佳答案楼层

林木水123

需求描述不清楚

哥儿-

Sub test()
    Dim i%, j%, k%, arr, brr, dic As Object, dic2 As Object
    arr = Range("A7").CurrentRegion
    brr = Range("H6").CurrentRegion
    Set dic = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")
    ReDim crr(1 To UBound(brr, 1), 1 To UBound(brr, 2))
    For i = 2 To UBound(brr, 1) - 1
        For k = 1 To UBound(arr, 2)
            dic(arr(i - 1, k)) = dic(arr(i - 1, k)) + 1
            dic2(arr(i, k)) = dic2(arr(i, k)) + 1
        Next k
        For j = 1 To UBound(brr, 2)
            If Not dic.exists(brr(1, j)) Then
                If brr(i, j) = "" And brr(i + 1, j) = "" Then crr(i, j) = brr(1, j)
                If dic2(crr(i, j)) = 1 Then Cells(i + 20, j + 41).Interior.ColorIndex = 43
            End If
        Next j
        dic.RemoveAll
        dic2.RemoveAll
    Next i
     Range("AP21").Resize(UBound(crr, 1), UBound(crr, 2)) = crr
     
End Sub