ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 求改代码

[复制链接]

TA的精华主题

TA的得分主题

发表于 2018-4-23 18:49 | 显示全部楼层 |阅读模式
详情请见附件: 求助改代码.zip (19.2 KB, 下载次数: 13)

TA的精华主题

TA的得分主题

发表于 2018-4-23 20:39 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
  1. Sub Y颜色标注()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     Application.ScreenUpdating = False
  4.     Union(Columns(2), Columns(9)).Interior.ColorIndex = 0
  5.     Union(Columns(2), Columns(9)).Font.ColorIndex = 0
  6.     For j = 2 To Cells(Rows.Count, "i").End(3).Row
  7.         If Len(Cells(j, "i")) > 0 Then Set d(Cells(j, "i").Value) = Cells(j, "i")
  8.     Next j
  9.     For j = 2 To Cells(Rows.Count, "b").End(3).Row
  10.         If d.exists(Cells(j, "b").Value) Then
  11.             Union(Cells(j, 2), d(Cells(j, "b").Value)).Interior.ColorIndex = 3
  12.         Else
  13.             If InStr(Cells(j, 2), "[") > 0 Then
  14.                 arr = Split(Split(Cells(j, 2), "]")(0), "[")
  15.                 If d.exists(arr(0)) And d.exists(arr(1)) Then
  16.                     Union(Cells(j, 2), d(arr(0)), d(arr(1))).Interior.ColorIndex = 3
  17.                 Else
  18.                     If d.exists(arr(0)) Then
  19.                         d(arr(0)).Interior.ColorIndex = 3
  20.                         Cells(j, 2).Characters(Start:=1, Length:=Len(arr(0))).Font.ColorIndex = 3
  21.                     End If
  22.                     
  23.                     If d.exists(arr(1)) Then
  24.                         d(arr(1)).Interior.ColorIndex = 3
  25.                         Cells(j, 2).Characters(Start:=2 + Len(arr(0)), Length:=Len(arr(1))).Font.ColorIndex = 3
  26.                     End If
  27.                 End If
  28.             End If
  29.         End If
  30.     Next j
  31.     Application.ScreenUpdating = True
  32. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-4-23 20:40 | 显示全部楼层
附件代码供参考。。。。

求助改代码.zip

11.67 KB, 下载次数: 1

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-4-25 19:28 | 显示全部楼层
liulang0808 发表于 2018-4-23 20:40
附件代码供参考。。。。

版主大神,很冒昧的打搅你,因上楼需改动的代码试用后觉着比以前的方便很多,但本想再将另一段代码加入进去,却不知加在哪里合适,只好再次求助大神的帮助。因需加入的代码只简单的判断字符,请大神先看看。 求助改代码A.zip (9.9 KB, 下载次数: 2)

TA的精华主题

TA的得分主题

发表于 2018-4-25 20:18 | 显示全部楼层
  1. Sub Y颜色标注()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     Application.ScreenUpdating = False
  4.     Union(Columns(2), Columns(9)).Interior.ColorIndex = 0
  5.     Union(Columns(2), Columns(9)).Font.ColorIndex = 0
  6.     For j = 2 To Cells(Rows.Count, "i").End(3).Row
  7.         If Len(Cells(j, "i")) > 0 Then Set d(Cells(j, "i").Value) = Cells(j, "i")
  8.     Next j
  9.     For j = 2 To Cells(Rows.Count, "b").End(3).Row
  10.         If d.exists(Cells(j, "b").Value) Then
  11.             Cells(j, 3) = Columns(9).Find(Cells(j, "b"), lookat:=xlWhole).Offset(0, 1)
  12.             
  13.             Union(Cells(j, 2), d(Cells(j, "b").Value)).Interior.ColorIndex = 22
  14.         Else
  15.             If InStr(Cells(j, 2), "[") > 0 Then
  16.                 arr = Split(Split(Cells(j, 2), "]")(0), "[")
  17.                 If d.exists(arr(0)) And d.exists(arr(1)) Then
  18.                     Union(Cells(j, 2), d(arr(0)), d(arr(1))).Interior.ColorIndex = 22
  19.                 Else
  20.                     If d.exists(arr(0)) Then
  21.                         d(arr(0)).Interior.ColorIndex = 3
  22.                         Cells(j, 2).Characters(Start:=1, Length:=Len(arr(0))).Interior.ColorIndex = 3
  23.                     End If
  24.                     
  25.                     If d.exists(arr(1)) Then
  26.                         d(arr(1)).Interior.ColorIndex = 3
  27.                         Cells(j, 2).Characters(Start:=1 + Len(arr(0)), Length:=Len(arr(1))).Font.ColorIndex = 3
  28.                     End If
  29.                 End If
  30.             End If
  31.         End If
  32.     Next j
  33.     Application.ScreenUpdating = True
  34. End Sub
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2018-4-25 20:18 | 显示全部楼层
附件内容供参考

求助改代码A.zip

11.2 KB, 下载次数: 4

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-4-25 21:20 | 显示全部楼层

大神,试了下,觉着在写入价格的时候,并没有判断B列的[]内外的字符,需要判断与B列的[]内或[]外的字符相同就写入价格。如果都不相同就不写入价格。求版主大神再帮忙

TA的精华主题

TA的得分主题

发表于 2018-4-25 21:21 | 显示全部楼层
LNS17 发表于 2018-4-25 21:20
大神,试了下,觉着在写入价格的时候,并没有判断B列的[]内外的字符,需要判断与B列的[]内或[]外的字符相 ...

结合附件模拟举例说明下

TA的精华主题

TA的得分主题

 楼主| 发表于 2018-4-26 17:24 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
liulang0808 发表于 2018-4-25 21:21
结合附件模拟举例说明下

谢谢大神,可能没有表达清楚,请看附件 求助改代码B.zip (11.53 KB, 下载次数: 1)

TA的精华主题

TA的得分主题

发表于 2018-4-26 19:49 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
  1. Sub Y颜色标注()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     Application.ScreenUpdating = False
  4.     Union(Columns(2), Columns(9)).Interior.ColorIndex = 0
  5.     Union(Columns(2), Columns(9)).Font.ColorIndex = 0
  6.     For j = 2 To Cells(Rows.Count, "i").End(3).Row
  7.         If Len(Cells(j, "i")) > 0 Then Set d(Cells(j, "i").Value) = Cells(j, "i")
  8.     Next j
  9.     For j = 2 To Cells(Rows.Count, "b").End(3).Row
  10.         If d.exists(Cells(j, "b").Value) Then
  11.             Cells(j, 3) = Columns(9).Find(Cells(j, "b"), lookat:=xlWhole).Offset(0, 1)
  12.             
  13.             Union(Cells(j, 2), d(Cells(j, "b").Value)).Interior.ColorIndex = 22
  14.         Else
  15.             If InStr(Cells(j, 2), "[") > 0 Then
  16.                 arr = Split(Split(Cells(j, 2), "]")(0), "[")
  17.                 If d.exists(arr(0)) And d.exists(arr(1)) Then
  18.                     Cells(j, 3) = Columns(9).Find(arr(0), lookat:=xlWhole).Offset(0, 1)
  19.                     Union(Cells(j, 2), d(arr(0)), d(arr(1))).Interior.ColorIndex = 22
  20.                 Else
  21.                     If d.exists(arr(0)) Then
  22.                         d(arr(0)).Interior.ColorIndex = 3
  23.                         Cells(j, 3) = Columns(9).Find(arr(0), lookat:=xlWhole).Offset(0, 1)
  24.                         Cells(j, 2).Characters(Start:=1, Length:=Len(arr(0))).Interior.ColorIndex = 3
  25.                     End If
  26.                     
  27.                     If d.exists(arr(1)) Then
  28.                         d(arr(1)).Interior.ColorIndex = 3
  29.                         Cells(j, 3) = Columns(9).Find(arr(1), lookat:=xlWhole).Offset(0, 1)
  30.                         Cells(j, 2).Characters(Start:=1 + Len(arr(0)), Length:=Len(arr(1))).Font.ColorIndex = 3
  31.                     End If
  32.                 End If
  33.             End If
  34.         End If
  35.     Next j
  36.     Application.ScreenUpdating = True
  37. End Sub
复制代码
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 08:03 , Processed in 0.057757 second(s), 14 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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