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

chensir

有括号提取括号内的品牌，无括号直接提取品牌，谢谢
之前考虑不周，附件重新来过

最佳答案

月排行榜 / 总排行榜

yyyydddd8888

2013-12-9 09:48

chensir 发表于 2013-12-9 09:18
多谢，能满足，验证时发现如果店名未写品牌，提取的品牌会把后面的品牌提到此店名前面，才造成错行

加了一个判断语句，如果不包含品牌，则此品牌为空。
(, 下载次数: 6)

上传

点击文件名下载附件

跳转到最佳答案楼层

云影

提取品牌.rar (7.25 KB, 下载次数: 19)

2013-12-6 17:09 上传

点击文件名下载附件

yuan1987

云影 发表于 2013-12-6 17:09

公式能分解一下么。

chensir

云影 发表于 2013-12-6 17:09

多谢，函数我可以解决，需要用VBA

E路人

chensir 发表于 2013-12-6 17:22
多谢，函数我可以解决，需要用VBA

1. Sub test()
   
2. Dim i, j, a, arr, arr1
   
3. Sheet1.Activate
   
4. arr = Range("B2:B" & [B65536].End(3).Row)
   
5. ReDim arr1(1 To UBound(arr, 1), 1 To 1)
   
6. For i = 1 To UBound(arr)
   
7. For j = 1 To Len(arr(i, 1))
   
8. a = Mid(arr(i, 1), j, 1)
   
9. If InStr(arr(i, 1), "(") = False Then
   
10. If a Like "[A-Z]" Then
    
11. arr1(i, 1) = arr1(i, 1) & a
    
12. End If
    
13. Else
    
14. arr1(i, 1) = Mid(arr(i, 1), InStr(arr(i, 1), "(") + 1, _
    
15. InStr(arr(i, 1), ")") - InStr(arr(i, 1), "(") - 1)
    
16. End If
    
17. Next j
    
18. Next i
    
19. [A2].Resize(UBound(arr1, 1), 1) = arr1
    
20. End Sub
    
21. 
    

复制代码

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 = "[A-Z]"
    
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

复制代码

chensir

E路人 发表于 2013-12-6 17:34

多谢，辛苦了。
验证了一下，如果把NK品牌换成NK360，就只能提取NK了，这和我之前例子中未考虑周全有关

比如 把“江苏1店NK”换成“江苏1店NK360”，该如何做呢
或有就是
      如果“江苏1店NK”换成 “A江苏1店NK360”，店名前面第一个会是一个字母，怎么弄？

谢谢

CheryBTL

chensir 发表于 2013-12-6 18:06
多谢，辛苦了。
验证了一下，如果把NK品牌换成NK360，就只能提取NK了，这和我之前例子中未考虑周全有关
...

如果前面也有数字，调整下规则，请测试：

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+"
    
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

复制代码

chensir

CheryBTL 发表于 2013-12-6 18:08
如果前面也有数字，调整下规则，请测试：

但是您这个括号里的提不出来，只能提NK360了，其他的比如NK和NK360同时有店时，NK就提不出了

chensir

CheryBTL 发表于 2013-12-6 18:08
如果前面也有数字，调整下规则，请测试：

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