excel数据处理(VBA 实现）

610784867

实现对选定区域内同一行内的重复值（相同值）填充底色，且空白单元格不填充，另外，选区用鼠标选择，且选定区域是可变的，请用VBA实现，谢谢！请高手多多指点

supermouse24

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    UsedRange.Interior.ColorIndex = xlNone
    If Target.Count > 1 Then
        Set Target = Target.Cells(1)
    ElseIf Target.Value = "" Then
        Exit Sub
    End If
   
    Dim irow, icol As Integer
    Dim rng As Range
    i = Target.Value
    irow = Target.Row
    icol = Range("z" & irow).End(xlToLeft).Column
    For Each rng In Range(Cells(irow, 1), Cells(irow, icol))
        If rng.Value = Target.Value Then
            rng.Interior.Color = 65535
        End If
    Next
   

End Sub

备注: 程序需要放在对应表下面的代码中.

附上附件 数据处理.rar (12.84 KB, 下载次数: 10)

2020-1-8 22:39 上传

点击文件名下载附件

觉得还可以,请献花.谢谢哈

answer6141

兄弟，看看几点了，你不给我花能过意的去么

answer6141

answer6141 发表于 2020-1-9 02:45
兄弟，看看几点了，你不给我花能过意的去么

1. Option Explicit
   
2. 
   
3. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
4.     Dim i, j, k, l, x, y As Integer
   
5.     Dim arr, brr
   
6.     Dim d As Object
   
7.     Dim rng As Range
   
8.    
   
9.     x = Target.Rows.Count
   
10.     y = Target.Columns.Count
    
11.     Set d = CreateObject("scripting.dictionary")
    
12.     If x > 0 And x < 30 And y > 1 And y < 30 Then
    
13.         arr = Target
    
14.         For i = LBound(arr) To UBound(arr)
    
15.             For j = LBound(arr, 2) To UBound(arr, 2)
    
16.                 If Len(arr(i, j)) > 0 Then
    
17.                     d(arr(i, j)) = d(arr(i, j)) & "连"
    
18.                 End If
    
19.             Next
    
20.             brr = d.keys
    
21.             For Each k In brr
    
22.                 If Len(d(k)) > 1 Then
    
23.                     For Each rng In Range(Target.Cells(i, 1), Target.Cells(i, y))
    
24.                         If rng.Value = k Then
    
25.                             rng.Interior.Color = vbGreen
    
26.                         End If
    
27.                         
    
28.                     Next
    
29.                 End If
    
30.             Next
    
31.             d.RemoveAll
    
32.         Next
    
33.     ElseIf y = 1 Then
    
34.         For Each rng In Target
    
35.             If rng = "" Then
    
36.                 Exit Sub
    
37.             End If
    
38.         Next
    
39.         
    
40.     End If
    
41. End Sub

复制代码

610784867

太感谢了！

1055751654

answer6141 发表于 2020-1-9 02:45
兄弟，看看几点了，你不给我花能过意的去么

老师在卖命的写代码

answer6141

@ 一下chxw68 这个是大师，看了大师的代码，字典是玩的66啊，我研究了10个小时起码，估计大师5分钟就搞定了，你这个我写了5个小时了，新手就是累啊 ，

1055751654

answer6141 发表于 2020-1-9 18:08
@ 一下chxw68 这个是大师，看了大师的代码，字典是玩的66啊，我研究了10个小时起码，估计大师5分钟就搞定了 ...

厉害了，看了下就会写这么一大串

answer6141

1055751654 发表于 2020-1-9 19:39
厉害了，看了下就会写这么一大串

研究了10个小时不是看了一下