|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
直接放在Change事件里吧
可能有的版本不持支数据有效性选择变动
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
Dim i&, Myr&, Arr, bsrr, ii, arr1
Dim d, k, t, dd, tt, cs, ttt, tttt
Dim js1, js2, js3, js4, js1add, js2add
Myr = Sheet1.[b65536].End(xlUp).Row
Arr = Sheet1.Range("b2:h" & Myr)
Dim all_ll
For i = 2 To UBound(Arr)
all_ll = Arr(i, 7)
ActiveSheet.Shapes.Range(Array("Freeform " & all_ll)).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 240)
.Transparency = 0
.Solid
End With
Next
Dim ll
Dim new_name
new_name = Sheet1.[I3].Text
For i = 2 To UBound(Arr)
If Arr(i, 6) = new_name Then
ll = Arr(i, 7)
ActiveSheet.Shapes.Range(Array("Freeform " & ll)).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With
End If
Next
Application.ScreenUpdating = True
Sheet1.[a1].Select
End Sub |
|