[已解决]跨表查找相同值并统计数量

xk2005

急求大神，一个工作簿里的两个工作表。sheet2第一列的数据，挨个去sheet1中查找，如果找到，就将sheet1和sheet2中的数据所在单元格都标红底，并在sheet2的第二列列出查找到的相同数值的量。如果没找到，则不标颜色，数量为空或者0都可以。详见附件

最佳答案

月排行榜 / 总排行榜

望帝春心

2016-11-30 14:34

1. Sub test() '望帝春心
   
2.     Dim rng As Range, rng1 As Range, cel As Range, cel1 As Range
   
3.     Set rng = Sheet1.UsedRange
   
4.     Set rng1 = Sheet2.Cells(2, 1).Resize(Sheet2.Cells(Rows.Count, 1).End(3).Row - 1)
   
5.     For Each cel In rng1
   
6.         For Each cel1 In rng
   
7.             If cel.Value = cel1.Value Then
   
8.                 n = n + 1
   
9.                 cel.Interior.ColorIndex = 3
   
10.                 cel1.Interior.ColorIndex = 3
    
11.             End If
    
12.         Next cel1
    
13.         cel.Offset(, 1) = n
    
14.         n = 0
    
15.     Next cel
    
16. End Sub

复制代码

跳转到最佳答案楼层

心正意诚身修

要返回數據 ,你就用VLOOKUP.直接返回.
要標示顏色.你就用條件格式去做.分兩步.

xk2005

心正意诚身修 发表于 2016-11-30 13:52
要返回數據 ,你就用VLOOKUP.直接返回.
要標示顏色.你就用條件格式去做.分兩步.

本人不太懂VBA，求老师直接写出代码

望帝春心

1. Sub test() '望帝春心
   
2.     Dim rng As Range, rng1 As Range, cel As Range, cel1 As Range
   
3.     Set rng = Sheet1.UsedRange
   
4.     Set rng1 = Sheet2.Cells(2, 1).Resize(Sheet2.Cells(Rows.Count, 1).End(3).Row - 1)
   
5.     For Each cel In rng1
   
6.         For Each cel1 In rng
   
7.             If cel.Value = cel1.Value Then
   
8.                 n = n + 1
   
9.                 cel.Interior.ColorIndex = 3
   
10.                 cel1.Interior.ColorIndex = 3
    
11.             End If
    
12.         Next cel1
    
13.         cel.Offset(, 1) = n
    
14.         n = 0
    
15.     Next cel
    
16. End Sub

复制代码

心正意诚身修

xk2005 发表于 2016-11-30 14:25
本人不太懂VBA，求老师直接写出代码

樓下有老師給你做出來了.
我也不懂VBA.不過一個簡單的引用函數和條件格式也是能做出來的.

grf1973

1. Sub tt()
   
2.     Dim x As Range
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     With Sheet2
   
5.         .UsedRange.Interior.ColorIndex = 0
   
6.         arr = .[a1].CurrentRegion
   
7.         For i = 2 To UBound(arr)
   
8.             d(arr(i, 1)) = 0
   
9.         Next
   
10.         
    
11.         With Sheet1
    
12.             .UsedRange.Interior.ColorIndex = 0
    
13.             For Each x In .UsedRange
    
14.                 If Len(x) Then
    
15.                     If d.exists(x.Value) Then
    
16.                         xstr = xstr & "," & x.Address(0, 0)
    
17.                         d(x.Value) = d(x.Value) + 1
    
18.                     End If
    
19.                 End If
    
20.             Next
    
21.             xstr = Mid(xstr, 2)
    
22.             If xstr <> "" Then .Range(xstr).Interior.ColorIndex = 3
    
23.         End With
    
24.    
    
25.         xstr = ""
    
26.         For i = 2 To UBound(arr)
    
27.             arr(i, 2) = d(arr(i, 1))
    
28.             If arr(i, 2) > 0 Then xstr = xstr & "," & Cells(i, 2).Address(0, 0)
    
29.         Next
    
30.         .[a1].CurrentRegion = arr
    
31.         xstr = Mid(xstr, 2)
    
32.         If xstr <> "" Then .Range(xstr).Interior.ColorIndex = 3
    
33.     End With
    
34. End Sub
    

复制代码

xk2005

望帝春心 发表于 2016-11-30 14:34

完全满足我的要求，太感谢老师了

sayhi95

xk2005 发表于 2016-11-30 15:03
完全满足我的要求，太感谢老师了

哈哈，解决了还请评个最佳吧