[已解决]求助，VBA如何实现不同工作表查找相同值并填充指定颜色

245747772

带有控件的查找

   大神帮下忙{:22:}

最佳答案

月排行榜 / 总排行榜

grf1973

2014-3-25 09:39

1. Sub tt()
   
2.     If Me.OptionButton1 = True Then x = 1    '根据选择框确定所要查找的工作表索引
   
3.     If Me.OptionButton2 = True Then x = 2
   
4.     If Me.OptionButton3 = True Then x = 3
   
5.     arr = Sheets(4).[a1].CurrentRegion
   
6.     Sheets(4).Range("a:a").Interior.ColorIndex = 0
   
7.     brr = Sheets(x).[a1].CurrentRegion
   
8.     Sheets(x).Range("b:b").Interior.ColorIndex = 0
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.    
    
11.     For i = 1 To UBound(arr)   '查找sheet1，存在于sheet4中
    
12.         d(arr(i, 1)) = ""
    
13.     Next
    
14.     For i = 1 To UBound(brr)
    
15.         If d.exists(brr(i, 2)) Then Sheets(x).Cells(i, 2).Interior.ColorIndex = 3
    
16.     Next
    
17.    
    
18.     d.RemoveAll
    
19.     For i = 1 To UBound(brr)   '查找sheet4，不存在于sheet1中
    
20.         d(brr(i, 2)) = ""
    
21.     Next
    
22.     For i = 1 To UBound(arr)
    
23.         If Not d.exists(arr(i, 1)) Then Sheets(4).Cells(i, 1).Interior.ColorIndex = 6
    
24.     Next
    
25. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     If Me.OptionButton1 = True Then x = 1    '根据选择框确定所要查找的工作表索引
   
3.     If Me.OptionButton2 = True Then x = 2
   
4.     If Me.OptionButton3 = True Then x = 3
   
5.     arr = Sheets(4).[a1].CurrentRegion
   
6.     Sheets(4).Range("a:a").Interior.ColorIndex = 0
   
7.     brr = Sheets(x).[a1].CurrentRegion
   
8.     Sheets(x).Range("b:b").Interior.ColorIndex = 0
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.    
    
11.     For i = 1 To UBound(arr)   '查找sheet1，存在于sheet4中
    
12.         d(arr(i, 1)) = ""
    
13.     Next
    
14.     For i = 1 To UBound(brr)
    
15.         If d.exists(brr(i, 2)) Then Sheets(x).Cells(i, 2).Interior.ColorIndex = 3
    
16.     Next
    
17.    
    
18.     d.RemoveAll
    
19.     For i = 1 To UBound(brr)   '查找sheet4，不存在于sheet1中
    
20.         d(brr(i, 2)) = ""
    
21.     Next
    
22.     For i = 1 To UBound(arr)
    
23.         If Not d.exists(arr(i, 1)) Then Sheets(4).Cells(i, 1).Interior.ColorIndex = 6
    
24.     Next
    
25. End Sub
    

复制代码

grf1973

请看附件。

245747772

不好意思，前几天出差，没时间上来




非常感谢{:091:}

245747772

grf1973 发表于 2014-3-25 09:39

请问一下，If Me.OptionButton4 = True Then x = 15  下标越界 什么解决？谢谢

grf1973

看看Sheets(15)是否存在

245747772

grf1973 发表于 2014-3-27 15:24
看看Sheets(15)是否存在

明白了，{:11:}

245747772

grf1973 发表于 2014-3-25 09:40
请看附件。

我想需要改善一下：
1.如 sheet1表B3出现空格,B4以及下面的表格都没有处理
2.Sheets(4) 的数据是更换的，如果换了数值sheet1表填充的颜色都会删除，更新了当前数值的颜色，可否保留所以填充的颜色？
如果sheet1 的颜色重复填充需要提醒。
                                                             谢谢

grf1973

1. Sub tt()
   
2.     If Me.OptionButton1 = True Then x = 1    '根据选择框确定所要查找的工作表索引
   
3.     If Me.OptionButton2 = True Then x = 2
   
4.     If Me.OptionButton3 = True Then x = 3
   
5.     r = Sheet(4).[b65536].End(3).Row: arr = Sheets(4).Range("a1:b" & r)
   
6.     'Sheets(4).Range("a:a").Interior.ColorIndex = 0
   
7.    
   
8.     r = Sheet(x).[b65536].End(3).Row: brr = Sheets(4).Range("a1:b" & r)
   
9.     'Sheets(x).Range("b:b").Interior.ColorIndex = 0
   
10.     Set d = CreateObject("scripting.dictionary")
    
11.    
    
12.     For i = 1 To UBound(arr)   '查找sheet1，存在于sheet4中
    
13.         d(arr(i, 1)) = ""
    
14.     Next
    
15.     For i = 1 To UBound(brr)
    
16.         If d.exists(brr(i, 2)) Then Sheets(x).Cells(i, 2).Interior.ColorIndex = 3
    
17.     Next
    
18.    
    
19.     d.RemoveAll
    
20.     For i = 1 To UBound(brr)   '查找sheet4，不存在于sheet1中
    
21.         d(brr(i, 2)) = ""
    
22.     Next
    
23.     For i = 1 To UBound(arr)
    
24.         If Not d.exists(arr(i, 1)) Then Sheets(4).Cells(i, 1).Interior.ColorIndex = 6
    
25.     Next
    
26. End Sub
    

复制代码

grf1973

第8句要改一下： r = Sheet(x).[b65536].End(3).Row: brr = Sheets(x).Range("a1:b" & r)
颜色重复填充要提示，怎么提示？弄个消息框出来？