[已解决]见附件要求，填充颜色

123456le

见附件要求，填充颜色 趣味 填充.rar (7.28 KB, 下载次数: 33)

2014-12-16 13:52 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

fffox

2014-12-16 15:48

123456le 发表于 2014-12-16 14:40
做了2个示例 老师看下。

1. Sub test2()
   
2.     Dim dic As Object
   
3.     Dim i%, j%, k%, endRow%, firstRow%
   
4.     Application.ScreenUpdating = False
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     With ActiveSheet
   
7.         endRow = .Cells(Rows.Count, 2).End(3).Row
   
8.         firstRow = .Cells(1, 2).End(4).Row
   
9.         For k = 2 To .Cells(firstRow, Columns.Count).End(1).Column
   
10.             For i = endRow To firstRow + 8 Step -1
    
11.                 Do
    
12.                     j = j + 1
    
13.                     dic(.Cells(i - j, k).Value) = ""
    
14.                 Loop Until dic.Count = 8 Or i - j = firstRow
    
15.                 If Not dic.exists(.Cells(i, k).Value) Then
    
16.                     If dic.Count = 8 Then
    
17.                         .Cells(i, k).Interior.Color = vbRed
    
18.                     End If
    
19.                 End If
    
20.                 dic.RemoveAll
    
21.                 j = 0
    
22.             Next
    
23.         Next
    
24.     End With
    
25.     Set dic = Nothing
    
26.     Application.ScreenUpdating = True
    
27. End Sub

复制代码

跳转到最佳答案楼层

fffox

1. Sub test()
   
2.     Dim i%, j%, k%, endRow%, firstRow%
   
3.     Application.ScreenUpdating = False
   
4.     With ActiveSheet
   
5.         endRow = .Cells(Rows.Count, 2).End(3).Row
   
6.         firstRow = .Cells(1, 2).End(4).Row
   
7.         For k = 2 To .Cells(firstRow, Columns.Count).End(1).Column
   
8.             For i = endRow To firstRow + 8 Step -1
   
9.                 For j = 1 To 8
   
10.                     If .Cells(i, k) = .Cells(i - j, k) Then GoTo 100
    
11.                 Next
    
12.                 .Cells(i, k).Interior.Color = vbRed
    
13. 100:
    
14.             Next
    
15.         Next
    
16.     End With
    
17.     Application.ScreenUpdating = True
    
18. End Sub
    

复制代码

123456le

fffox 发表于 2014-12-16 14:21

你好老师，要求填充单元格的前面必须是8个数字是不同的。

123456le

fffox 发表于 2014-12-16 14:21

做了2个示例 老师看下。 趣味3.rar (8.02 KB, 下载次数: 6)

2014-12-16 14:40 上传

点击文件名下载附件

fffox

123456le 发表于 2014-12-16 14:40
做了2个示例 老师看下。

1. Sub test2()
   
2.     Dim dic As Object
   
3.     Dim i%, j%, k%, endRow%, firstRow%
   
4.     Application.ScreenUpdating = False
   
5.     Set dic = CreateObject("scripting.dictionary")
   
6.     With ActiveSheet
   
7.         endRow = .Cells(Rows.Count, 2).End(3).Row
   
8.         firstRow = .Cells(1, 2).End(4).Row
   
9.         For k = 2 To .Cells(firstRow, Columns.Count).End(1).Column
   
10.             For i = endRow To firstRow + 8 Step -1
    
11.                 Do
    
12.                     j = j + 1
    
13.                     dic(.Cells(i - j, k).Value) = ""
    
14.                 Loop Until dic.Count = 8 Or i - j = firstRow
    
15.                 If Not dic.exists(.Cells(i, k).Value) Then
    
16.                     If dic.Count = 8 Then
    
17.                         .Cells(i, k).Interior.Color = vbRed
    
18.                     End If
    
19.                 End If
    
20.                 dic.RemoveAll
    
21.                 j = 0
    
22.             Next
    
23.         Next
    
24.     End With
    
25.     Set dic = Nothing
    
26.     Application.ScreenUpdating = True
    
27. End Sub

复制代码

qh8600

1. Dim ar, d, str As String
   
2. Sub demo()
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     ar = Range("b3").CurrentRegion
   
5.     ActiveSheet.UsedRange.Interior.ColorIndex = xlNone
   
6.     For j = 1 To UBound(ar, 2)
   
7.         For i = UBound(ar) To 1 Step -1
   
8.             Call demo1(i - 1, j)
   
9.             If InStr(Val(str), ar(i, j)) = 0 And d.Count = 8 Then Cells(i + 2, j + 1).Interior.ColorIndex = 3
   
10.             str = "": d.RemoveAll
    
11.         Next
    
12.     Next
    
13. End Sub
    
14. Sub demo1(x, y)
    
15.     For m = x To 1 Step -1
    
16.         d(ar(m, y)) = ""
    
17.         If d.Count = 8 Then Exit For
    
18.     Next
    
19.     m = d.keys
    
20.     For l = 0 To UBound(m)
    
21.         str = str & m(l)
    
22.     Next
    
23. End Sub
    

复制代码

趣味 填充.rar (19.28 KB, 下载次数: 6)

2014-12-16 16:17 上传

点击文件名下载附件