涂色代码修改

ddz79101

老师！我想将未提取到的信息，涂色。现有代码只是对提取的代码涂色了，而未对需提而未提到的信息涂色。请老师帮忙再看看。谢谢！另抱歉，这是第2个问题，急了，未单独发送。

ww87725244

1. 重新写了一个
   
2. Sub aa()
   
3. Dim ar, i, rng As Range
   
4. With Worksheets("中心")
   
5.   ar = .Range("d2:e" & .Range("d65535").End(3).Row)
   
6.   For i = 1 To UBound(ar)
   
7.     Set rng = Worksheets("票").Range("d2:d" & Worksheets("票").Range("d2").End(xlDown).Row).Find(ar(i, 1))
   
8.       If rng Is Nothing Then
   
9.           .Range(.Cells(i + 1, 1), .Cells(i + 1, 10)).Interior.ColorIndex = 3
   
10.       Else
    
11.           Worksheets("票").Range("f" & rng.Row) = ar(i, 2)
    
12.       End If
    
13.   Next
    
14. End With
    
15. End Sub

复制代码

shiruiqiang

字典，union

shiruiqiang

if dic.exists(brr(x,1))
两表都有的数据变成红色

ddz79101

shiruiqiang 发表于 2024-6-3 22:52
if dic.exists(brr(x,1))
两表都有的数据变成红色

谢谢老师！好像没有提取到吗？花没有了，后补

ykcbf1100

小改一下即可。

ykcbf1100

小改一下，加上颜色

1. Sub ykcbf()   '//2024.6.4
   
2.     Dim arr, d
   
3.     Application.ScreenUpdating = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("票")
   
6.         r = .Cells(.Rows.Count, 4).End(xlUp).Row
   
7.         arr = .[d1].Resize(r, 6)
   
8.     End With
   
9.     For i = 2 To UBound(arr)
   
10.         s = CStr(arr(i, 1))
    
11.         d(s) = i
    
12.     Next
    
13.     On Error Resume Next
    
14.     With Sheets("中心")
    
15.         r = .Cells(.Rows.Count, "d").End(xlUp).Row
    
16.         brr = .[d1].Resize(r, 5)
    
17.         For i = 2 To UBound(brr)
    
18.             s = CStr(brr(i, 1))
    
19.             If d.Exists(s) Then
    
20.                 .Cells(i, 6) = arr(d(s), 4)
    
21.                 .Cells(i, 7) = arr(d(s), 5)
    
22.                 .Cells(i, 8) = arr(d(s), 6)
    
23.             Else
    
24.                 .Cells(i, 6).Resize(, 3).Cells.Interior.ColorIndex = 6
    
25.             End If
    
26.         Next
    
27.     End With
    
28.     Set d = Nothing
    
29.     Application.ScreenUpdating = True
    
30.     MsgBox "OK！"
    
31. End Sub
    
32. 
    

复制代码

ddz79101

ww87725244 发表于 2024-6-3 22:36

谢谢老师！运行成功！

ddz79101

shiruiqiang 发表于 2024-6-3 22:44
字典，union

谢谢老师！代码成功

ddz79101

ykcbf1100 发表于 2024-6-4 07:02
小改一下即可。

谢谢老师！代码运行成功