|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
描述得不清不楚,还好有贴图:
分别找出B、D和F列不被数值1分隔的数值2的个数,若数值2的个数连续存在4个及以上,则在该起止区域的左侧列的对应区域填充黄底色。
参考下列代码:
- Sub kkk()
- Dim theFinalRow&, i&, j&, k&, m&, n&, theCell As Range
- Dim arr As Variant, theCount&
- '
- With ActiveSheet
- For i = 1 To 5 Step 2
- .Columns(i).Interior.ColorIndex = -4142
- Next i
- '
- With .Columns("A:F")
- Set theCell = .Find("*", .Cells(1), xlValues, xlPart, xlByRows, xlPrevious, False, False, False)
- End With
- '
- If Not theCell Is Nothing Then
- theFinalRow = theCell.Row
- Else
- GoTo The_Exit
- End If
- '
- arr = .Range(.Cells(1, 1), .Cells(theFinalRow, 6))
- For j = 2 To 6 Step 2
- For i = 1 To UBound(arr)
- If arr(i, j) = 2 Then
- k = i
- m = k
- theCount = 1
- Do While m < theFinalRow
- m = m + 1
- If arr(m, j) = 2 Then
- theCount = theCount + 1
- n = m
- Else
- If arr(m, j) = 1 Then Exit Do
- End If
- Loop
- i = m
- '
- If theCount > 3 Then .Range(.Cells(k, j - 1), .Cells(n, j - 1)).Interior.ColorIndex = 6
- End If
- Next i
- Next j
- End With
- The_Exit:
- Set theCell = Nothing
- End Sub
复制代码
|
评分
-
1
查看全部评分
-
|