[已解决]求对满足连续重复的数据进行填充颜色，急，求求高手们了

lingdu

如题要求，对C:J列的数据的8这个数字连续重复出现超过8次的填充颜色，谢谢高手们了，由于数据量会有好十几万之多，所以，只能到这来麻烦高手们了，



谢谢了，谢谢大家了

最佳答案

月排行榜 / 总排行榜

grf1973

2014-12-10 09:55

请看附件。

跳转到最佳答案楼层

lingdu

谢谢高手们了，谢谢了

ghostjiao

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, i&, j&
   
3.     Dim iStart&, iEnd&, n%
   
4.     arr = Sheet1.Range("a1").CurrentRegion.Value
   
5.     For j = 3 To UBound(arr, 2)
   
6.         For i = 2 To UBound(arr)
   
7.             If arr(i, j) = 8 Then
   
8.                 iStart = i
   
9.                 Do While arr(i, j) = 8 And i < UBound(arr)
   
10.                     n = n + 1
    
11.                     i = i + 1
    
12.                 Loop
    
13.                 If n >= 8 Then
    
14.                     iEnd = i - 1
    
15.                     With Sheet1
    
16.                         .Range(.Cells(iStart, j), .Cells(iEnd, j)).Interior.ColorIndex = 3
    
17.                     End With
    
18.                 End If
    
19.                 n = 0
    
20.                 i = i - 1
    
21.             End If
    
22.         Next
    
23.     Next
    
24. End Sub

复制代码

grf1973

换个思路

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, i&, j&
   
3.     Dim iStart&, iEnd&
   
4.     Dim xFlag As Boolean
   
5.     Dim iRng As Range
   
6.     With Sheet1
   
7.         arr = .Range("a1").CurrentRegion.Value
   
8.         For j = 3 To UBound(arr, 2)
   
9.             For i = 2 To UBound(arr)
   
10.                 If arr(i, j) = 8 Then
    
11.                     If xFlag = False Then iStart = i: xFlag = True
    
12.                 ElseIf xFlag = True Then
    
13.                     iEnd = i - 1
    
14.                     If iEnd - iStart >= 7 Then
    
15.                         If iRng Is Nothing Then
    
16.                             Set iRng = .Range(.Cells(iStart, j), .Cells(iEnd, j))
    
17.                         Else
    
18.                             Set iRng = Union(iRng, .Range(.Cells(iStart, j), .Cells(iEnd, j)))
    
19.                         End If
    
20.                     End If
    
21.                     xFlag = False
    
22.                 End If
    
23.             Next
    
24.         Next
    
25.         If Not iRng Is Nothing Then iRng.Interior.ColorIndex = 3
    
26.     End With
    
27. End Sub
    

复制代码

grf1973

请看附件。