跨表确认标色

xing_chen

老师，有表，其中有公司的数据合理性需要另表是否在册予以确定。若在册，则不合理，涂色。情况见表中注解。敬请老师赐教。谢谢

liulang0808

Sub 按钮1_Click()
    Set d = CreateObject("scripting.dictionary")
    Application.ScreenUpdating = False
    Sheets("2").Columns("b:f").Interior.ColorIndex = 0
    arr = Sheets("名称").UsedRange
    For j = 2 To UBound(arr)
        If Len(arr(j, 1)) > 0 Then d(arr(j, 1)) = ""
    Next j
    arr = Sheets("2").UsedRange
    Set Rng = Nothing
    For j = 2 To UBound(arr)
        If d.exists(arr(j, 2)) Then
            If arr(j, 4) > 0 Then
                Cells(j, 2).Resize(1, 3).Interior.ColorIndex = 3
            End If
            If arr(j, 5) < 0 Then
                Cells(j, 2).Resize(1, 4).Interior.ColorIndex = 3
            End If
        End If
    Next j
    Application.ScreenUpdating = True
End Sub

liulang0808

供参考。。。。。

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar, i&, dic As Object, Rng As Range
   
    Set dic = CreateObject("Scripting.Dictionary")
    ar = Sheets(1).[A1].CurrentRegion
    For i = 2 To UBound(ar): dic(ar(i, 1)) = "": Next
   
    Set Rng = [A1].CurrentRegion
       With Rng
          .Interior.ColorIndex = 0
          ar = Rng
          For i = 2 To UBound(ar)
             If dic.exists(ar(i, 2)) Then
                If ar(i, 4) <> "" Then
                   Cells(i, 1).Resize(, UBound(ar, 2)).Interior.Color = vbRed
                ElseIf ar(i, 5) < 0 Then
                   Cells(i, 1).Resize(, UBound(ar, 2)).Interior.Color = vbRed
                End If
             End If
          Next i
       End With
      
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

参与 一下。。。

tanglf188

smiletwo

xing_chen

liulang0808 发表于 2023-2-7 07:14
供参考。。。。。

谢谢老师！运行如愿。

xing_chen

gwjkkkkk 发表于 2023-2-7 10:05
参与 一下。。。

谢谢老师！运行如愿。
抱歉！花在旅途，估计明天到达，到时献上

xing_chen

smiletwo 发表于 2023-2-7 12:48

谢谢老师！运行后没有反应，不知何因。我的代码输入如下
Sub ss()
    Dim i, arr, brr, d As Object
    arr = Sheet1.Range("A1").CurrentRegion
    brr = Sheet2.Range("A1").CurrentRegion
    Set d = CreateObject("Scripting.dictionary")
    For i = 2 To UBound(brr)
        If brr(i, 4) <> "" Or brr(i, 5) < 0 Then
            d(brr(i, 2)) = ""
        End If
    Next i
    For i = 2 To UBound(arr)
        If d.exists(arr(i, 1)) Then
            Sheet1.Range("A" & i).Interior.Color = vbRed
        End If
    Next i
    Set d = Nothing
End Sub
我检查了几遍，没有发现代码输入有异。敬请指教