求修改以前的VBA，支持新规则的关键字。

lpl625

以前论坛大哥写的，很好用。现需支持新规则的关键字提取。

1、182行以上的提取规则须保留（不包含黄色物料）
2、182行以下的物料提取规则需右边红色框的关键字
请直接改附件，成功后回复上传。谢谢！

1. Sub 提取()
   
2. Set reg = CreateObject("vbscript.regexp")
   
3. reg.ignorecase = True
   
4. With Sheets(1)
   
5.   k = .Cells(65536, 2).End(xlUp).Row
   
6.   For i = 1 To k
   
7.     reg.Pattern = "^\s*.*?([^/]*?°[^/]*).*|^[一-龡]+/([^/]+/)?([\.\d]+([m-z][hf])?)/.*"
   
8.     If reg.test(.Cells(i, 2)) Then
   
9.     .Cells(i, 3) = "'" & reg.Replace(.Cells(i, 2), "$1$3")
   
10.     Else
    
11.     reg.Pattern = "^\s*.*?((?=[^/]*?[a-z])([^\(/一-龡]*\d+[^\(/一-龡]*)+).*"
    
12.     .Cells(i, 3) = reg.Replace(.Cells(i, 2), "$1")
    
13.     End If
    
14.   Next i
    
15. End With
    
16. End Sub
    

复制代码

lpl625

可以改吗？

liulang0808

Sub 提取()
Set reg = CreateObject("vbscript.regexp")
reg.ignorecase = True
With Sheets(1)
  k = .Cells(65536, 2).End(xlUp).Row
  For i = 1 To 182
    reg.Pattern = "^\s*.*?([^/]*?°[^/]*).*|^[一-龡]+/([^/]+/)?([\.\d]+([m-z][hf])?)/.*"
    If reg.test(.Cells(i, 2)) Then
    .Cells(i, 3) = "'" & reg.Replace(.Cells(i, 2), "$1$3")
    Else
    reg.Pattern = "^\s*.*?((?=[^/]*?[a-z])([^\(/一-龡]*\d+[^\(/一-龡]*)+).*"
    .Cells(i, 3) = reg.Replace(.Cells(i, 2), "$1")
    End If
  Next i
  For j = 183 To k
    If Len(.Cells(j, 4)) > 0 Then
        arr = Split(.Cells(j, 4), "/")
        For i = 0 To 1
            If InStr(.Cells(j, 2), arr(i)) = 0 Then GoTo l1
        Next i
        .Cells(j, 3) = arr(0)
l1:
    End If
  Next j
End With

End Sub

liulang0808

需求没有看懂，猜了一下，不知道对不对的

lpl625

liulang0808 发表于 2024-8-17 10:45
需求没有看懂，猜了一下，不知道对不对的

试了。182行以下的物料提取规则需右边红色框的关键字，没有实现。

汉唐

猜下规律，用的是函数，没用正则

liulang0808

lpl625 发表于 2024-8-17 11:39
试了。182行以下的物料提取规则需右边红色框的关键字，没有实现。

把你182行以下部分数据提取原则描述清楚，结合结果说明一下

lpl625

liulang0808 发表于 2024-8-17 13:11
把你182行以下部分数据提取原则描述清楚，结合结果说明一下

C列，是原来的提取规则的数据。D列最下面黄色红框是我手工写的关键词，需要新规则能自动提取到C列。

lpl625

汉唐 发表于 2024-8-17 11:58
猜下规律，用的是函数，没用正则

没有实现：D列最下面黄色红框是我手工写的关键词，需要新规则能自动提取到C列。

lpl625

谁能优化一下代码？