批量判断相应列单元格的数字并进行底部染色

LVMJ2023 · 发表于 2023-7-9 09:44

请各位老师帮忙看下，万分感谢

gwjkkkkk · 发表于 2023-7-9 10:39

请参考。。。

gwjkkkkk · 发表于 2023-7-9 10:40

请参考。。。

chxw68 · 发表于 2023-7-9 10:46

Sub test()
Dim r%, i%, c%, j%, m%, x%
Dim arr, brr, zrr()
With Worksheets("sheet1")
r = .Cells(.Rows.Count, 3).End(xlUp).Row
c = .Cells(9, .Columns.Count).End(xlToLeft).Column
arr = .Range("c9").Resize(r - 8, c - 2)
For j = 1 To UBound(arr, 2)
x = 1000
m = 0
For i = 1 To UBound(arr)
If arr(i, j) <> x Then
m = m + 1
ReDim Preserve zrr(1 To m)
zrr(m) = Array(i, i)
x = arr(i, j)
Else
If m > 0 Then
zrr(m)(1) = i
End If
End If
Next
For k = 1 To UBound(zrr)
If zrr(k)(1) - zrr(k)(0) + 1 = 2 Then
.Cells(zrr(k)(0) + 8, j + 2).Resize(2, 1).Interior.ColorIndex = 6
ElseIf zrr(k)(1) - zrr(k)(0) + 1 > 2 Then
.Cells(zrr(k)(0) + 8, j + 2).Resize(zrr(k)(1) - zrr(k)(0) + 1, 1).Interior.ColorIndex = 3
End If
Next
Next
End With
End Sub

复制代码

鄂龙蒙 · 发表于 2023-7-9 10:46

染色.rar (17.57 KB, 下载次数: 5)

chxw68 · 发表于 2023-7-9 10:47

详见附件。

鄂龙蒙 · 发表于 2023-7-9 10:59

相同个数区别开来

【单元格条件填充颜色】.rar (16.16 KB, 下载次数: 9)

LVMJ2023 · 发表于 2023-7-9 12:01

鄂龙蒙发表于 2023-7-9 10:46

多谢，对比了下，你写的更好些

cidanji · 发表于 2023-7-9 12:11

鄂龙蒙发表于 2023-7-9 10:46

4楼最优。。

		自动登录	找回密码
密码			免费注册

[求助] 批量判断相应列单元格的数字并进行底部染色