[已解决]求助:如何寻找相同值并标示?

zhouxingyu

是个非常麻烦的问题:要找出相同的数值组合,行列还不固定.
哪位老师帮忙看看能否实现?说明详见附件.多谢了!
寻找相同值.rar (7.71 KB, 下载次数: 23)

2012-1-15 18:47 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

sunjing-zxl

2012-1-15 21:55

1. Sub bb()
   
2.     Dim d As New Dictionary
   
3.     Dim arr, i As Long, j As Long
   
4.     Dim Ro As Long, Co As Long
   
5.     Application.ScreenUpdating = False
   
6.     arr = Range(Cells(2, "F"), Cells([F65536].End(xlUp).Row, [F2].End(xlToRight).column))
   
7.     For i = 1 To UBound(arr) Step 3
   
8.         For j = 1 To UBound(arr, 2)
   
9.             If Not d.Exists(arr(i, j) & vbTab & arr(i + 1, j)) Then
   
10.                 d.Add arr(i, j) & vbTab & arr(i + 1, j), Array(i, j)
    
11.             Else
    
12.                 Ro = d(arr(i, j) & vbTab & arr(i + 1, j))(0)
    
13.                 Co = d(arr(i, j) & vbTab & arr(i + 1, j))(1)
    
14.                 Range(Cells(Ro + 1, Co + 5), Cells(Ro + 2, Co + 5)).Font.Color = -16776961
    
15.                 Range(Cells(i + 1, j + 5), Cells(i + 2, j + 5)).Font.Color = -16776961
    
16.             End If
    
17.         Next j
    
18.     Next i
    
19.     Application.ScreenUpdating = True
    
20. End Sub

复制代码

跳转到最佳答案楼层

sunjing-zxl

1. Sub aa()
   
2.     Dim d As New Dictionary
   
3.     Dim arr, i As Long, j As Long
   
4.     Dim Ro As Long, Co As Long
   
5.     Application.ScreenUpdating = False
   
6.     arr = Range(Cells(2, "F"), Cells([F65536].End(xlUp).Row, [F2].End(xlToRight)))
   
7.     For i = 1 To UBound(arr) Step 3
   
8.         For j = 1 To UBound(arr, 2)
   
9.             If Not d.Exists(arr(i, j) & arr(i + 1, j)) Then
   
10.                 d.Add arr(i, j) & arr(i + 1, j), Array(i, j)
    
11.             Else
    
12.                 Ro = d(arr(i, j) & arr(i + 1, j))(0)
    
13.                 Co = d(arr(i, j) & arr(i + 1, j))(1)
    
14.                 Range(Cells(Ro + 1, Co + 5), Cells(Ro + 2, Co + 5)).Font.Color = -16776961
    
15.                 Range(Cells(i + 1, j + 5), Cells(i + 2, j + 5)).Font.Color = -16776961
    
16.             End If
    
17.         Next j
    
18.     Next i
    
19.     Application.ScreenUpdating = True
    
20. End Sub

复制代码

sunjing-zxl

附件： 寻找相同值-sunjing.rar (12.67 KB, 下载次数: 25)

2012-1-15 20:05 上传

点击文件名下载附件
行列都可以扩展，但是起点必须E2开始

qqyyh

    认真向你学习,谢谢!

zhouxingyu

sunjing-zxl 发表于 2012-1-15 20:06
附件：
行列都可以扩展，但是起点必须E2开始

感谢老师.你实在是强,好像就没有能难的住你的.
还有2个小问题请教:数值只能是二位数的是吗?如果数值为0-9的一位数,只能对F和G二列产生作用.
你指的起点必须从E2开始,有点不明白.不是F2?

sunjing-zxl

对是F2我写错了。
如果你的数字位数不定程序还需要修改一点点

sunjing-zxl

1. Sub bb()
   
2.     Dim d As New Dictionary
   
3.     Dim arr, i As Long, j As Long
   
4.     Dim Ro As Long, Co As Long
   
5.     Application.ScreenUpdating = False
   
6.     arr = Range(Cells(2, "F"), Cells([F65536].End(xlUp).Row, [F2].End(xlToRight).column))
   
7.     For i = 1 To UBound(arr) Step 3
   
8.         For j = 1 To UBound(arr, 2)
   
9.             If Not d.Exists(arr(i, j) & vbTab & arr(i + 1, j)) Then
   
10.                 d.Add arr(i, j) & vbTab & arr(i + 1, j), Array(i, j)
    
11.             Else
    
12.                 Ro = d(arr(i, j) & vbTab & arr(i + 1, j))(0)
    
13.                 Co = d(arr(i, j) & vbTab & arr(i + 1, j))(1)
    
14.                 Range(Cells(Ro + 1, Co + 5), Cells(Ro + 2, Co + 5)).Font.Color = -16776961
    
15.                 Range(Cells(i + 1, j + 5), Cells(i + 2, j + 5)).Font.Color = -16776961
    
16.             End If
    
17.         Next j
    
18.     Next i
    
19.     Application.ScreenUpdating = True
    
20. End Sub

复制代码

zhouxingyu

sunjing-zxl 发表于 2012-1-15 21:55

是这样:如果是选择性粘粘的数值,只对二列产生作用.
是手动输入的就没有问题.

sunjing-zxl

这个情况不应该存在的                  

zhouxingyu

sunjing-zxl 发表于 2012-1-15 22:16
这个情况不应该存在的

那我再去试试,一再麻烦你不好意思的很.真的很感谢你!