ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[求助] 型号提取问题,是否可用正则表达式一步完成,高手留步!

[复制链接]

TA的精华主题

TA的得分主题

发表于 2016-9-22 15:41 | 显示全部楼层 |阅读模式
  1. Sub 结算表型号提取()
  2.           Dim Reg, Arr, x%, mat, ma, Brr, Crr, y&, z&
  3.           Application.ScreenUpdating = False
  4.           Set Reg = CreateObject("Vbscript.RegExp")
  5.           With Reg
  6.                     .Global = True
  7.                     '.Pattern = "((?!zy美的)[a-zA-Z0-9\-]+)((?!美的)[\u4e00-\u9fa5]+)"
  8.                     .Pattern = "([\u4e00-\u9fa5]+)([a-zA-Z0-9\-]+)([\u4e00-\u9fa5]+)?"
  9.           End With
  10.           Arr = Range("a1:k" & Cells(Rows.Count, 3).End(3).Row)
  11.           Brr = Array("美的", "西施", "白玉瓷", "玲珑", "智能")
  12.           Crr = Array("MB-", "MD-")
  13.           For x = 2 To UBound(Arr)
  14.                     Set mat = Reg.Execute(Arr(x, 5))
  15.                     For Each ma In mat
  16.                               Arr(x, 9) = ma.submatches(0)
  17.                               Arr(x, 10) = ma.submatches(1)
  18.                               Arr(x, 11) = ma.submatches(2)
  19.                     Next ma
  20.           Next x
  21.           For y = 0 To UBound(Brr)
  22.                     For x = 2 To UBound(Arr)
  23.                               If Arr(x, 9) = "" Then Arr(x, 9) = Arr(x, 11)
  24.                               If InStr(Arr(x, 9), Brr(y)) Then Arr(x, 9) = Replace(Arr(x, 9), Brr(y), "")
  25.                     Next x
  26.           Next y
  27.           For z = 0 To UBound(Crr)
  28.                      For x = 2 To UBound(Arr)
  29.                               If InStr(Arr(x, 10), Crr(z)) Then Arr(x, 10) = Replace(Arr(x, 10), Crr(z), "")
  30.                     Next x
  31.           Next z
  32.           Range("a1").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
  33.           Range("i1").Resize(1, 3) = Array("中文", "英文", "辅助列")
  34.           Sheet1.UsedRange.Borders.LineStyle = 1
  35.           Application.ScreenUpdating = True
  36. End Sub
复制代码
求助理由:
1、因为从系统导出的产品型号极其不规范,需进行整理以便后期统计分析使用;
2、以上代码综合运用正则,instr和replace函数,为本人所写,限于个人水平,
勉强能达到目标,但自我感觉通用性不强,后期维护估计会耗费较多时间;
3、请问是否可以用更为精准的正则表达式,而不结合使用instr和replace函数实现目标?

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-9-22 15:42 | 显示全部楼层
详见附件。

求助-结算表型号提取.rar

23.97 KB, 下载次数: 36

TA的精华主题

TA的得分主题

发表于 2016-9-22 16:38 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册

型号:[\w-]{4,}(?=[一-龥((])
品名(在submatches(0))中: 美的[\w-]*(?:西施|白玉瓷|玲珑|智能)?([一-龥]+)

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-9-22 16:57 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
liu-aguang 发表于 2016-9-22 16:38
型号:[\w-]{4,}(?=[一-龥((])
品名(在submatches(0))中: 美的[\w-]*(?:西施|白玉瓷|玲珑|智能)?([一- ...

老师,您好,可否在原有代码上帮助修改一下呢?我水平有限,不会使用您提供的正则表达式。感谢。

TA的精华主题

TA的得分主题

发表于 2016-9-22 17:22 | 显示全部楼层
jsgj2023 发表于 2016-9-22 16:57
老师,您好,可否在原有代码上帮助修改一下呢?我水平有限,不会使用您提供的正则表达式。感谢。

捕获.PNG

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2016-9-22 20:17 | 显示全部楼层
  1. Sub 结算表型号提取2()
  2.             Sheets("sheet0").Activate
  3.             Arr = Range("a1").CurrentRegion
  4.             ReDim Brr(1 To UBound(Arr), 1 To 2)
  5.             Set regA = CreateObject("vbscript.regexp")
  6.             Set regB = CreateObject("vbscript.regexp")
  7.             regA.Pattern = "美的[\w-]*(?:西施|白玉瓷|玲珑|智能)?([一-龥]+)"
  8.             regB.Pattern = "[\w-]{4,}(?=[一-龥((])"
  9.             For i = 2 To UBound(Arr)
  10.                         Set mhA = regA.Execute(Arr(i, 5))
  11.                         Set mhB = regB.Execute(Arr(i, 5))
  12.                         If mhA.Count Then Brr(i, 1) = mhA(0).submatches(0)
  13.                         If mhB.Count Then Brr(i, 2) = mhB(0)
  14.             Next i
  15.             Range("I1").Resize(UBound(Arr), 2) = Brr
  16. End Sub
复制代码


把楼上老师的代码抄写一遍,也方便需要的人。

TA的精华主题

TA的得分主题

发表于 2018-9-20 11:48 | 显示全部楼层
  1. Sub 完成分离()
  2.     Application.ScreenUpdating = False
  3.     Dim ran As Range
  4.     Dim e As New RegExp
  5.     Set e = CreateObject("VBscript.RegExp")
  6.     With e
  7.         .Global = True
  8.         .IgnoreCase = True
  9.         .Pattern = "(美的)((([一-龢]+)([A-Z0-9-]+))|(([A-Z0-9-]+)([一-龢]+)))(?=\()"
  10.         For Each rn In Range([e2], Cells(Rows.Count, "e").End(3))
  11.             Set mat = .Execute(rn)    'Matches集合中的每个Match对象索引号从0开始
  12.             Cells(rn.Row, "I") = mat(0).submatches(3)    'match对象的属性之一SubMatches索引号也从从0开始
  13.             Cells(rn.Row, "J") = mat(0).submatches(4)    'submatches(4)其实是第5个分组
  14.             Cells(rn.Row, "K") = mat(0).submatches(6)    'submatches(6)其实是第7个分组
  15.             Cells(rn.Row, "L") = mat(0).submatches(7)    'submatches(7)其实是第8个分组
  16.         Next
  17.     End With
  18.     For Each ran In Range([k2], Cells(Rows.Count, "k").End(3))
  19.         If Len(ran) > 0 Then ran.Cut Cells(ran.Row, "J")
  20.     Next
  21.     For Each ran In Range([L2], Cells(Rows.Count, "L").End(3))
  22.         If Len(ran) > 0 Then ran.Cut Cells(ran.Row, "I")
  23.     Next
  24.     Range("K:K,L:L").Delete
  25. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2018-9-20 12:16 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2018-9-20 13:01 | 显示全部楼层
  1. Sub 结算表型号提取()
  2.           Dim Reg, Arr, x%, mat, ma, Brr, Crr, y&, z&
  3.           Application.ScreenUpdating = False
  4.           Set Reg = CreateObject("Vbscript.RegExp")
  5.           With Reg
  6.                     .Global = True
  7.                     .Pattern = "(美的|西施|白玉瓷|玲珑|智能)(\W+?)([A-Za-z0-9\-]+)|(美的|西施|白玉瓷|玲珑|智能)([A-Za-z0-9\-]+)([^(]+)"
  8.           End With
  9.           Arr = Range("a1:j" & Cells(Rows.Count, 3).End(3).Row)

  10.           For x = 2 To UBound(Arr)
  11.                     Set mat = Reg.Execute(Arr(x, 5))
  12.                     For Each ma In mat
  13.                               Arr(x, 9) = ma.submatches(1) & ma.submatches(5)
  14.                               Arr(x, 10) = ma.submatches(2) & ma.submatches(4)
  15.                     Next ma
  16.           Next x
  17.           Range("a1").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
  18.           Application.ScreenUpdating = True
  19. End Sub
复制代码

TA的精华主题

TA的得分主题

发表于 2018-9-20 13:39 | 显示全部楼层
alstar 发表于 2018-9-20 12:16
挖坟的技术可以啊。

U CAN U UP    我只是在做练习   这个题比较经典  将来我自己遇到了类似问题一查就看得到
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2025-1-15 21:31 , Processed in 0.028263 second(s), 14 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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