[已解决]请教老师vba

qh8600

1401.rar (11.48 KB, 下载次数: 7)

2014-3-9 11:40 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

独奏

2014-3-9 12:33

1. Sub text()
   
2. Dim arr, d, d1, dk, r, c, str
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d1 = CreateObject("scripting.dictionary")
   
5. With Sheets("单号")
   
6. arr = .Range("A4:n" & .[a65536].End(xlUp).Row)
   
7. For r = LBound(arr) To UBound(arr)
   
8.     str = ""
   
9.     For c = 2 To UBound(arr, 2)
   
10.         str = str & arr(r, c) & "-"
    
11.     Next
    
12.     If Not d.exists(str) Then
    
13.         d(str) = ""
    
14.     Else
    
15.         d1(str) = ""
    
16.     End If
    
17. Next
    
18. dk = d1.keys
    
19. For x = LBound(dk) To UBound(dk)
    
20.     For r = LBound(arr) To UBound(arr)
    
21.         str = ""
    
22.         For c = 2 To UBound(arr, 2)
    
23.             str = str & arr(r, c) & "-"
    
24.         Next
    
25.         If str = dk(x) Then
    
26.             Range(Cells(r + 3, 1), Cells(r + 3, 14)).Font.ColorIndex = 3
    
27.         End If
    
28.     Next
    
29. Next
    
30. End With
    
31. End Sub
    

复制代码

跳转到最佳答案楼层

独奏

1. Sub text()
   
2. Dim arr, d, d1, dk, r, c, str
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d1 = CreateObject("scripting.dictionary")
   
5. With Sheets("单号")
   
6. arr = .Range("A4:n" & .[a65536].End(xlUp).Row)
   
7. For r = LBound(arr) To UBound(arr)
   
8.     str = ""
   
9.     For c = 2 To UBound(arr, 2)
   
10.         str = str & arr(r, c) & "-"
    
11.     Next
    
12.     If Not d.exists(str) Then
    
13.         d(str) = ""
    
14.     Else
    
15.         d1(str) = ""
    
16.     End If
    
17. Next
    
18. dk = d1.keys
    
19. For x = LBound(dk) To UBound(dk)
    
20.     For r = LBound(arr) To UBound(arr)
    
21.         str = ""
    
22.         For c = 2 To UBound(arr, 2)
    
23.             str = str & arr(r, c) & "-"
    
24.         Next
    
25.         If str = dk(x) Then
    
26.             Range(Cells(r + 3, 1), Cells(r + 3, 14)).Font.ColorIndex = 3
    
27.         End If
    
28.     Next
    
29. Next
    
30. End With
    
31. End Sub
    

复制代码