怎样才能让宏自动帮我查找清空区域？

合肥狮子

yangyangzhifeng 发表于 2013-1-5 00:45
你的工作表有太多函数，现改为数组及禁事件和改为手动重算，速度应该可以了

您好！
我想以这个宏为基础再做个宏，《怎样才能让宏自动帮我查找并替换成白色字体区域？》
意思是把原来的需要清空的区域，不清空了，改成“白色字体”，让人看不见即可，不清除了。
请帮忙帮我再做一下这个宏，谢谢！

yangyangzhifeng

合肥狮子 发表于 2013-1-15 11:50
您好！
我想以这个宏为基础再做个宏，《怎样才能让宏自动帮我查找并替换成白色字体区域？》
意思是把 ...

将清除内容代码改为修改字体颜色即可，试试看

1. Sub 事中选定区域清空()
   
2.     Dim Myarr As Range, i&, conf1, conf2, ar, rng As Range, st$, c&, r&, rr As Range, brr, rw, cc
   
3.     On Error Resume Next
   
4.     conf1 = MsgBox("是否已备份 确认清空内容 ", vbYesNo)
   
5.     Set Myarr = Application.InputBox("请选择清空范围", "选择", Type:=8)
   
6.     If Err <> 0 Then MsgBox "没有选择区域", 64, "温馨提示": Exit Sub
   
7.     conf2 = InputBox("请输入确认密码", "密码输入框")
   
8.     If conf2 <> "123" Then MsgBox "密码错误！": Exit Sub
   
9.     ar = Split(Myarr.Address, "$")
   
10.     Set rng = Myarr.Find("通讯录", lookat:=xlWhole, searchorder:=xlByRows)
    
11.     st = rng.Address: r = rng.Row
    
12.     Application.ScreenUpdating = False
    
13.     brr = Myarr: rw = Myarr.Row: cc = Myarr.Column
    
14.     Application.EnableEvents = False
    
15.     Application.Calculation = xlCalculationManual
    
16.     Do
    
17.         c = rng.Column
    
18.         For i = r To Val(ar(UBound(ar)))
    
19.             If brr(i - rw + 1, c - cc + 1) <> "通讯录" And brr(i - rw + 1, c - cc + 1) <> "住址 电话 QQ" Then
    
20.                 If rr Is Nothing Then Set rr = Cells(i, c) Else Set rr = Union(rr, Cells(i, c))
    
21.                 If rr.Areas.Count = 255 Then rr.Font.Color = vbWhite: Set rr = Nothing
    
22.             End If
    
23.         Next
    
24.         If Not rr Is Nothing Then rr.ClearContents
    
25.         Set rng = Myarr.FindNext(rng)
    
26.     Loop Until rng.Address = st Or rng.Row <> r
    
27.     If Not rr Is Nothing Then rr.Font.Color = vbWhite
    
28.     Application.Calculation = xlCalculationAutomatic
    
29.     Application.EnableEvents = True
    
30.     Application.ScreenUpdating = True
    
31. End Sub
    

复制代码