|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
- Sub 标色()
- Sheet1.Cells.Interior.ColorIndex = xlNone
- Dim m, i, j, arr, brr(), crr(), d As Object
- Set d = CreateObject("scripting.dictionary")
- arr = Sheet1.Range("J80").CurrentRegion
- For j = 1 To UBound(arr, 2)
- m = 0
- d.RemoveAll
- Erase brr
- d(arr(UBound(arr), j)) = ""
- For i = j To UBound(arr)
- If d.exists(arr(i, j)) Then
- m = m + 1
- ReDim Preserve brr(1 To 2, 1 To m)
- brr(1, m) = s
- brr(2, m) = i + 79
- End If
- Next
- If m > 0 Then
- Erase crr
- ReDim crr(1 To m - 1, 1 To 3)
- For i = 1 To m - 1
- crr(i, 1) = brr(2, i)
- crr(i, 2) = brr(2, i + 1)
- crr(i, 3) = brr(2, i + 1) - brr(2, i)
- Next
- For i = 1 To m - 3
- If crr(i, 3) = crr(i + 1, 3) And crr(i + 1, 3) = crr(i + 2, 3) Then
- Cells(crr(i, 1), j + 9).Interior.ColorIndex = 3
- Cells(crr(i + 1, 1), j + 9).Interior.ColorIndex = 3
- Cells(crr(i + 2, 1), j + 9).Interior.ColorIndex = 3
- Cells(crr(m - 1, 2), j + 9).Interior.ColorIndex = 3
- End If
- Next
- End If
- Next
- Set d = Nothing
- End Sub
复制代码 |
|