烦请写个VBA,谢谢

飞越一切 · 发表于 2024-2-29 17:57

见附件

自动用红色显示数字.rar (9.57 KB, 下载次数: 10)

杨建营 · 发表于 2024-2-29 18:17

本帖最后由杨建营于 2024-2-29 18:29 编辑

修改了一个条件，请楼主参考。

swl4561255 · 发表于 2024-2-29 18:23

Private Sub CommandButton1_Click()
Dim a As Range
For Each a In Range("B2:L19")
If WorksheetFunction.CountIf(Range("V2:AH2"), a.Value) Then
a.Interior.ColorIndex = 3
End If
Next
End Sub

复制代码

^星^ · 发表于 2024-2-29 18:41

未使用VBA

自动用红色显示数字.zip (11.47 KB, 下载次数: 5)

gwjkkkkk · 发表于 2024-2-29 18:45

Option Explicit
Sub TEST1()
Dim ar, i&, j&, rngFind As Range

ar = [V2:AH20].Value

With Range("B2", Cells(Rows.Count, "L").End(xlUp))
      .Interior.Color = xlNone
      For i = 1 To UBound(ar)
         For j = 1 To UBound(ar, 2)
            Set rngFind = .Find(ar(i, j), , , xlWhole)
            If Not rngFind Is Nothing Then
                  rngFind.Interior.Color = vbRed
            End If
         Next j
      Next i
End With

Set rngFind = Nothing
End Sub

gwjkkkkk · 发表于 2024-2-29 18:48

请参考附件。。。

ykcbf1100 · 发表于 2024-2-29 18:49

附件供参考。。。

ykcbf1100 · 发表于 2024-2-29 18:49

参与一下。。。

Sub ykcbf() '//2024.2.29
Set d = CreateObject("Scripting.Dictionary")
Me.Cells.Interior.ColorIndex = 0
zrr = Me.[v2:ah2]
For j = 1 To UBound(zrr, 2)
d(zrr(1, j)) = ""
Next
r = Me.Cells(Rows.Count, 2).End(3).Row
arr = Me.[a1].Resize(r, 12)
For i = 2 To UBound(arr)
For j = 1 To UBound(arr, 2)
s = arr(i, j)
If d.exists(s) Then
Me.Cells(i, j).Interior.ColorIndex = 3
End If
Next
Next
End Sub

复制代码

ykcbf1100 · 发表于 2024-2-29 18:52

换个写法。。

Sub ykcbf() '//2024.2.29
Set d = CreateObject("Scripting.Dictionary")
Me.Cells.Interior.ColorIndex = 0
zrr = Me.[v2:ah2]
For j = 1 To UBound(zrr, 2)
d(zrr(1, j)) = ""
Next
r = Me.Cells(Rows.Count, 2).End(3).Row
Set Rng = Me.[a1].Resize(r, 12)
For Each rn In Rng
s = rn.Value
If d.exists(s) Then
rn.Interior.ColorIndex = 3
End If
Next
End Sub

复制代码

飞越一切 · 发表于 2024-3-1 13:54

杨建营发表于 2024-2-29 18:17
修改了一个条件，请楼主参考。

非常感谢，非常感谢

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

烦请写个VBA,谢谢

评分

评分

评分