2个不同区域，同一行进行比较，相同的标注颜色，同一区域内不比较

飞越一切

相同的用颜色标注，区域列数会有增删，求一个公式还在VBA

2个不同区域同一行进行比较.rar (10.82 KB, 下载次数: 10)

2024-4-22 15:16 上传

点击文件名下载附件

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     r = Cells(Rows.Count, 1).End(3).Row
   
5.     arr = [a1].Resize(r, 29)
   
6.     Cells.Interior.ColorIndex = 0
   
7.     For i = 2 To UBound(arr)
   
8.         d.RemoveAll: d1.RemoveAll
   
9.         For j = 1 To 19
   
10.             s = arr(i, j)
    
11.             If s <> Empty Then
    
12.                 d(s) = ""
    
13.             End If
    
14.         Next
    
15.         For j = 21 To UBound(arr, 2)
    
16.             s = arr(i, j)
    
17.             If s <> Empty Then
    
18.                 d1(s) = ""
    
19.             End If
    
20.         Next
    
21.         For j = 1 To 19
    
22.             s = arr(i, j)
    
23.             If s <> Empty Then
    
24.                 If d.exists(s) Then
    
25.                     If d1.exists(s) Then
    
26.                         Cells(i, j).Cells.Interior.ColorIndex = 6
    
27.                     End If
    
28.                 End If
    
29.             End If
    
30.         Next
    
31.         For j = 21 To UBound(arr, 2)
    
32.             s = arr(i, j)
    
33.             If s <> Empty Then
    
34.                 If d.exists(s) Then
    
35.                     If d1.exists(s) Then
    
36.                         Cells(i, j).Cells.Interior.ColorIndex = 6
    
37.                     End If
    
38.                 End If
    
39.             End If
    
40.         Next
    
41.     Next
    
42.     Set d = Nothing
    
43.     MsgBox "OK！"
    
44. End Sub
    

复制代码

飞越一切

ykcbf1100 发表于 2024-4-22 16:18
附件供参考。。。

大神，区域1我增加到27列 ，可以用不

ykcbf1100

飞越一切 发表于 2024-4-22 16:39
大神，区域1我增加到27列 ，可以用不

那要改代码，行增减是不影响的。。。

飞越一切

ykcbf1100 发表于 2024-4-22 16:44
那要改代码，行增减是不影响的。。。

大神，改那个地方

飞越一切

ykcbf1100 发表于 2024-4-22 16:44
那要改代码，行增减是不影响的。。。

大神，烦请传个区域1为27列的附件，谢谢

ykcbf1100

飞越一切 发表于 2024-4-22 18:06
大神，烦请传个区域1为27列的附件，谢谢

你上附件吧。

gwjkkkkk

飞越一切 发表于 2024-4-22 16:39
大神，区域1我增加到27列 ，可以用不

这个需要区域重新定位。。。

chxw68

1. Sub test()
   
2.     Dim r%, i%
   
3.     Dim arr, brr
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     With Worksheets("sheet1")
   
7.         r = .UsedRange.Find(what:="*", LookIn:=xlValues, lookat:=xlWhole, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
   
8.         c1 = .Cells(1, 1).End(xlToRight).Column
   
9.         c2 = .Cells(1, .Columns.Count).End(xlToLeft).Column
   
10.         arr = .Range("a1").Resize(r, c2)
    
11.         For i = 2 To UBound(arr)
    
12.             If Len(arr(i, 2)) = 0 Or Len(arr(i, UBound(arr, 2))) = 0 Then
    
13.                 Exit For
    
14.             End If
    
15.             d.RemoveAll
    
16.             For j = 2 To c1
    
17.                 d(arr(i, j)) = j
    
18.             Next
    
19.             For j = c1 + 2 To c2
    
20.                 If d.exists(arr(i, j)) Then
    
21.                     .Cells(i, j).Interior.ColorIndex = 6
    
22.                     .Cells(i, d(arr(i, j))).Interior.ColorIndex = 6
    
23.                 End If
    
24.             Next
    
25.         Next
    
26.     End With
    
27. End Sub
    

复制代码