ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 638|回复: 9

[已解决] 求VBA代替条件格式

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-1-14 14:06 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
本帖最后由 meishishen 于 2019-1-15 17:06 编辑

如果用条件格式,数据量庞大时会运行会非常缓慢,所以想求教VBA方法。最好能实时显示,无需刷新,如果不行,也可以添加按钮,点击后判断是否重复后标记也可以。
详见附件,谢谢大家! Book1.zip (6.67 KB, 下载次数: 4)


TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-14 15:22 | 显示全部楼层
TIM图片20190114152113.png
附图,楼上有附件,劳驾哪位老师帮忙看一下,网上我找了些方法,改了下好像都不行,应该是我改错了,所以特来求教~

TA的精华主题

TA的得分主题

发表于 2019-1-14 17:03 | 显示全部楼层
本帖最后由 tyxvba7529 于 2019-1-15 17:06 编辑

写得不好,试下是否符合
  1. Sub test()
  2. Dim srr As String
  3. Dim x As Integer, y As Integer
  4. Set d = CreateObject("scripting.dictionary")
  5. Cells.Font.ColorIndex = xlAutomatic
  6. arr = [a1].CurrentRegion

  7. For x = 2 To UBound(arr, 1)
  8.   For y = 1 To UBound(arr, 2)
  9.     If y = 10 Or y = 11  Then
  10.         If arr(x, y) = "未连通" Or arr(x, y) = "空白" Or _
  11.            arr(x, y) = "其他" Or arr(x, y) = "个人" Then
  12.            chuli x, y, srr
  13.         End If
  14.     End If
  15.    
  16.     If y = 2 Or y = 3 Then
  17.         If Len(arr(x, y)) > 0 Then
  18.         d(arr(x, y)) = d(arr(x, y)) + 1
  19.         End If
  20.     End If
  21.    
  22.   Next
  23. Next


  24. For x = 2 To UBound(arr, 1)
  25.   For y = 1 To UBound(arr, 2)
  26.     If y = 2 Or y = 3 Then
  27.      If arr(x, y) <> "" Then
  28.         If d(arr(x, y)) > 1 Then
  29.             chuli x, y, srr
  30.         End If
  31.      End If
  32.     End If
  33.   Next
  34. Next


  35. If Len(srr) > 0 Then
  36. Range(srr).Font.Color = vbRed
  37. End If


  38. End Sub


  39. Function chuli(x As Integer, y As Integer, sr As String)

  40. If sr = "" Then
  41. sr = Cells(x, y).Address(0, 0)
  42. Else
  43. sr = sr & "," & Cells(x, y).Address(0, 0)
  44. End If

  45. If Len(sr) > 250 Then
  46. Range(sr).Font.Color = vbRed
  47. sr = ""
  48. End If

  49. End Function
复制代码

TA的精华主题

TA的得分主题

发表于 2019-1-14 17:10 | 显示全部楼层
增加change事件放sheet模块下, 见附件,实时更新
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. If Target.Row = 1 Then Exit Sub
  3. If Target.Column = 2 Or Target.Column = 3 _
  4. Or Target.Column = 10 Or Target.Column = 11 Then
  5.     Call test
  6. End If


  7. End Sub
复制代码

Book1.rar

12.3 KB, 下载次数: 13

TA的精华主题

TA的得分主题

发表于 2019-1-14 17:24 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
帮你顶一下

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-15 16:09 | 显示全部楼层
tyxvba7529 发表于 2019-1-14 17:10
增加change事件放sheet模块下, 见附件,实时更新

非常感谢老师帮助,我试一下。谢谢

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-15 16:10 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-15 16:18 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
tyxvba7529 发表于 2019-1-14 17:10
增加change事件放sheet模块下, 见附件,实时更新

你好老师,测试没问题。
我把公式应用到我的表中后,因为我的表里Sheet模块已经有个change事件了,怎么办,求教?
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 2 And Target.Count = 1 Then
If Len(Target.Value) <= 7 Then
Target.Value = Target.Value + 2780000000#
End If
End If
End Sub

TA的精华主题

TA的得分主题

发表于 2019-1-15 16:42 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 tyxvba7529 于 2019-1-15 16:47 编辑

那加在一起
  1. Private Sub Worksheet_Change(ByVal Target As Range)
  2. If Target.Row = 1 Then Exit Sub
  3. If Target.Column = 2 Or Target.Column = 3 _
  4. Or Target.Column = 10 Or Target.Column = 11 Then
  5.     Call test
  6. End If

  7. If Target.Column = 2 And Target.Count = 1 Then
  8.     If Len(Target.Value) <= 7 Then
  9.     Target.Value = Target.Value + 2780000000#
  10.     End If
  11. End If
  12. End Sub
复制代码

Book1.rar

11.95 KB, 下载次数: 4

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-15 17:03 | 显示全部楼层

谢谢好像可以了,奇了怪了还,刚才我也是这么融合到一起的咋不行,为什么用您的就可以,呵呵
哦还有个小问题,我原来的表格中设置了字体格式的,比如颜色什么的,现在直接默认成黑色字体了,哈哈,不过关系不大,谢谢老师指导
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-3-29 16:31 , Processed in 0.056448 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表