[已解决]求助，提取品牌

chensir

CheryBTL 发表于 2013-12-6 18:06
请楼主测试：

之前考虑不周，附件重新来过

CheryBTL

chensir 发表于 2013-12-6 18:10
但是您这个括号里的提不出来，只能提NK360了，其他的比如NK和NK360同时有店时，NK就提不出了

我再看下，字母后面带数字的正则怎么写

CheryBTL

水平有限，一次性完成有困难，分二次完成了，请测试：

1. Sub 品牌特性()
   
2.     Dim ar, re
   
3.     Dim Rnum As Integer, i As Integer
   
4.     Dim str As String, mats As Object, mat As Object
   
5.     Dim objregexp As Object
   
6.     Set objregexp = CreateObject("VBScript.regExp")
   
7.     Rnum = Sheets(1).[b65536].End(3).Row
   
8.     ar = Sheets(1).Range("B2:B" & Rnum)
   
9.     ReDim re(1 To UBound(ar), 1 To 1)
   
10.     For i = 1 To UBound(ar)
    
11.         If InStr(ar(i, 1), "(") > 0 Then
    
12.             str = "\(\w+\d+\)"
    
13.         Else
    
14.             str = "\w+\d+\b"
    
15.         End If
    
16.         temp = ""
    
17.         With objregexp
    
18.             .Global = True
    
19.             .Pattern = str
    
20.             Set mats = .Execute(ar(i, 1))
    
21.             For Each mat In mats
    
22.                 temp = temp & mat
    
23.             Next
    
24.         End With
    
25.         If temp = "" Then
    
26.             With objregexp
    
27.                 .Global = True
    
28.                 .Pattern = "\w{2,99}"
    
29.                 Set mats = .Execute(ar(i, 1))
    
30.                 For Each mat In mats
    
31.                     temp = temp & mat
    
32.                 Next
    
33.             End With
    
34.         End If
    
35.         If InStr(temp, "(") > 0 Then
    
36.             re(i, 1) = Replace(Replace(temp, "(", ""), ")", "")
    
37.         Else
    
38.             re(i, 1) = temp
    
39.         End If
    
40.     Next i
    
41.     Sheets(1).[a2].Resize(UBound(re)) = re
    
42. End Sub

复制代码

yyyydddd8888

CheryBTL 发表于 2013-12-6 18:27
水平有限，一次性完成有困难，分二次完成了，请测试：

正在学习正则表达式，可以作为参考！

CheryBTL

经花花指点，8楼代码调整下即可：

1. Sub 品牌特性()
   
2.     Dim ar, re
   
3.     Dim Rnum As Integer, i As Integer
   
4.     Dim str As String, mats As Object, mat As Object
   
5.     Dim objregexp As Object
   
6.     Set objregexp = CreateObject("VBScript.regExp")
   
7.     Rnum = Sheets(1).[b65536].End(3).Row
   
8.     ar = Sheets(1).Range("B2:B" & Rnum)
   
9.     ReDim re(1 To UBound(ar), 1 To 1)
   
10.     For i = 1 To UBound(ar)
    
11.         If InStr(ar(i, 1), "(") > 0 Then
    
12.             str = "\(\w+\d+\)"
    
13.         Else
    
14.             str = "[A-Z]{2,99}\d*"
    
15.         End If
    
16.         temp = ""
    
17.         With objregexp
    
18.             .Global = True
    
19.             .Pattern = str
    
20.             Set mats = .Execute(ar(i, 1))
    
21.             For Each mat In mats
    
22.                 temp = temp & mat
    
23.             Next
    
24.         End With
    
25.         If InStr(temp, "(") > 0 Then
    
26.             re(i, 1) = Replace(Replace(temp, "(", ""), ")", "")
    
27.         Else
    
28.             re(i, 1) = temp
    
29.         End If
    
30.     Next i
    
31.     Sheets(1).[a2].Resize(UBound(re)) = re
    
32. End Sub

复制代码

yyyydddd8888

用cheryBTL的代码稍作修改，用了个预搜索：(?=\))，这样可以少一步用replace替换的过程。


提取品牌改进2.zip (12.98 KB, 下载次数: 3)

2013-12-7 11:31 上传

点击文件名下载附件

1. Sub 提取品牌()
   
2. Dim reg As Object, mats As Object, mat As Object
   
3. Dim arr, ar(1 To 100000, 1 To 1), st1$, st2$, i&, j&, k, lastrow&
   
4. lastrow = Range("B" & Rows.Count).End(xlUp).Row
   
5. arr = Range("B2:B" & lastrow)
   
6. Set reg = CreateObject("vbscript.regexp")
   
7.     For i = 1 To UBound(arr)
   
8.         If InStr(arr(i, 1), ")") Then
   
9.             st1 = "\w{2,100}(?=\))"
   
10.         Else
    
11.             st1 = "[A-Z]{2,100}\d*"
    
12.         End If
    
13.         With reg
    
14.             .Global = True
    
15.             .ignorecase = False
    
16.             .Pattern = st1
    
17.             Set mats = .Execute(arr(i, 1))
    
18.             For Each mat In mats
    
19.                 k = k + 1
    
20.                 st2 = mat
    
21.                 ar(k, 1) = st2
    
22.             Next mat
    
23.         End With
    
24.     Next i
    
25.     Set mats = Nothing
    
26.     Set mat = Nothing
    
27.     Set reg = Nothing
    
28.     Range("A2").Resize(k + 20, 1) = ""
    
29.     Range("A2").Resize(k, 1) = ar
    
30. End Sub

复制代码

sliang28

瞎弄的,就附件给出规律而言

1. Sub sliang28()
   
2.     Dim reg As Object
   
3.     Dim myStr As String, myResult As String
   
4.     Dim arr, brr
   
5.     Set reg = CreateObject("VBScript.RegExp")
   
6.         arr = Sheets("Sheet1").Range("B2:B8")
   
7.         For i = 1 To UBound(arr)
   
8.             With reg
   
9.                 .Global = True
   
10.                 .Pattern = ".*(?=店.)"
    
11.                  myStr = .Replace(arr(i, 1), "")
    
12.                 .Pattern = "[\u4e00-\u9fe5]|.*\("
    
13.                 myResult = .Replace(myStr, "")
    
14.             End With
    
15.             j = j + 1
    
16.             arr(j, 1) = Application.Substitute(myResult, ")", "")
    
17.         Next
    
18.         With Sheets("Sheet1")
    
19.             .Range("C2").Resize(j, 1).ClearContents
    
20.             .Range("C2").Resize(j, 1) = arr
    
21.         End With
    
22. End Sub

复制代码

从从容容

用8楼修改一下
Sub 品牌特性()
    Dim ar, re
    Dim Rnum As Integer, i As Integer
    Dim str As String, mats As Object, mat As Object
    Dim objregexp As Object
    Set objregexp = CreateObject("VBScript.regExp")
    Rnum = Sheets(1).[b65536].End(3).Row
    ar = Sheets(1).Range("B2:B" & Rnum)
    ReDim re(1 To UBound(ar), 1 To 1)
    For i = 1 To UBound(ar)
        If InStr(ar(i, 1), "(") > 0 Then
            str = "\(\w+\d+\)"
        Else
            str = "[A-Z]{2,}"
        End If
        temp = ""
        With objregexp
            .Global = True
            .Pattern = str
            Set mats = .Execute(ar(i, 1))
            For Each mat In mats
                temp = temp & mat
            Next
        End With
        If InStr(temp, "(") > 0 Then
            re(i, 1) = Replace(Replace(temp, "(", ""), ")", "")
        Else
            re(i, 1) = temp
        End If
    Next i
    Sheets(1).[a2].Resize(UBound(re)) = re
End Sub

chensir

从从容容 发表于 2013-12-7 17:17
用8楼修改一下
Sub 品牌特性()
    Dim ar, re

多谢，括号内品牌提取不出

chensir

CheryBTL 发表于 2013-12-6 19:53
经花花指点，8楼代码调整下即可：

多谢，括号内品牌提取不出