能够自动根据新闻标题抽取关键词，分类和品牌的新闻分类表

zopey

1. Sub Button3_Click()
   
2. Dim arr, k0
   
3. Set dic = CreateObject("Scripting.Dictionary")
   
4. 
   
5. With Worksheets("Keywords_Catalog_Brand")
   
6. For j = 1 To 3
   
7.      k0 = .[a1].Offset(0, j - 1).End(4).Row - 1
   
8.      arr = .[a2].Offset(0, j - 1).Resize(k0, 1)
   
9.      
   
10.      For i = 1 To k0
    
11.         tb = Split(arr(i, 1), " ")
    
12.         For t = 0 To UBound(tb)
    
13.             dic(tb(t) & "") = j
    
14.         Next
    
15.      Next i
    
16. Next j
    
17. End With
    
18. 
    
19. '''''''''''''''''
    
20. Dim brr, temp
    
21. 
    
22. k0 = [h2].End(4).Row - 2
    
23. brr = [h3].Resize(k0, 1)
    
24. 
    
25. For i = 1 To k0
    
26.     temp = Split(brr(i, 1), " ")
    
27.     For j = 0 To UBound(temp)
    
28.         temp(j) = Replace(temp(j), "'s", "")
    
29.         If dic.exists(temp(j) & "") Then
    
30.            t0 = dic(temp(j) & "")
    
31.            If Cells(i + 2, 8 - t0) = "" Then
    
32.               Cells(i + 2, 8 - t0) = temp(j)
    
33.            Else
    
34.               Cells(i + 2, 8 - t0) = Cells(i + 2, 8 - t0) & "," & temp(j)
    
35.            End If
    
36.         End If
    
37.     Next
    
38. Next
    
39. 
    
40. End Sub

复制代码

略作修改，还有个问题是：字母大小写要统一处理，你自己解决吧。

jeros

zopey 发表于 2019-6-20 09:30
略作修改，还有个问题是：字母大小写要统一处理，你自己解决吧。

好的，这个我应该可以搞定。多个步骤用函数解决吧。
感谢感谢，我等空下来研究研究。太感谢了！

lsdongjh

1. Sub Test()
   
2.     Dim SH As Worksheet, lngRows As Long, arr As Variant
   
3.     Dim strPat_KeyWord As String, strPat_Category As String, strPat_Brand As String, arrPat As Variant
   
4.    
   
5.     Set SH = Sheets("Keywords_Catalog_Brand")
   
6.    
   
7.     lngRows = SH.Range("A" & Rows.Count).End(xlUp).Row
   
8.     arr = SH.Range("A2:A" & lngRows)
   
9.     arr = Application.WorksheetFunction.Transpose(arr)
   
10.     strPat_KeyWord = Space(1) & Join(arr, Space(1) & "|" & Space(1)) & Space(1)
    
11.    
    
12.     lngRows = SH.Range("B" & Rows.Count).End(xlUp).Row
    
13.     arr = SH.Range("B2:B" & lngRows)
    
14.     arr = Application.WorksheetFunction.Transpose(arr)
    
15.     strPat_Category = Space(1) & Join(arr, Space(1) & "|" & Space(1)) & Space(1)
    
16.    
    
17.     lngRows = SH.Range("D" & Rows.Count).End(xlUp).Row
    
18.     arr = SH.Range("D2:D" & lngRows)
    
19.     arr = Application.WorksheetFunction.Transpose(arr)
    
20.     strPat_Brand = Space(1) & Join(arr, Space(1) & "|" & Space(1)) & Space(1)
    
21.    
    
22.     ReDim arrPat(1 To 3)
    
23.     arrPat(1) = strPat_Brand
    
24.     arrPat(2) = strPat_Category
    
25.     arrPat(3) = strPat_KeyWord
    
26.    
    
27.    
    
28.     Set SH = Sheets("2018")
    
29.     lngRows = SH.Range("H" & Rows.Count).End(xlUp).Row
    
30.     arr = SH.Range("H3:H" & lngRows)
    
31.    
    
32.     arr = GetInfo(arr, arrPat)
    
33. 
    
34.     SH.Range("E3").Resize(UBound(arr), 3) = arr
    
35. End Sub
    
36. 
    
37. 
    
38. Function GetInfo(arr As Variant, arrPat As Variant) As Variant
    
39.     Dim objReg As Object, strTemp As String, strPat As String, lngID As Long
    
40.     Dim objMatchs As Object, objMatch As Object, strVal As String
    
41.     Dim lngRow As Long, arrResult As Variant
    
42.    
    
43.     lngRow = UBound(arr)
    
44.     ReDim arrResult(1 To lngRow, 1 To 3)
    
45.    
    
46.     Set objReg = CreateObject("VBScript.RegExp")
    
47.     objReg.Global = True
    
48.     objReg.IgnoreCase = True
    
49.    
    
50.     For lngRow = LBound(arr) To UBound(arr)
    
51.         strTemp = Space(1) & Trim(arr(lngRow, 1)) & Space(1)
    
52.         For lngID = 1 To 3
    
53.             objReg.Pattern = arrPat(lngID)
    
54.             Set objMatchs = objReg.Execute(strTemp)
    
55.             For Each objMatch In objMatchs
    
56.                 strVal = strVal & "、" & Trim(objMatch)
    
57.             Next
    
58.             arrResult(lngRow, lngID) = Mid(strVal, 2)
    
59.             strVal = ""
    
60.         Next
    
61.     Next
    
62.    
    
63.     GetInfo = arrResult
    
64.    
    
65. End Function
    

复制代码

lsdongjh

代码审核中，见附件 News to Columns.rar (51.92 KB, 下载次数: 21)

2019-6-20 13:34 上传

点击文件名下载附件

jeros

lsdongjh 发表于 2019-6-20 13:28

感谢大神！
虽然论坛把这个搞乱码了   strVal = strVal & "、" & Trim(objMatch)
但好歹分步骤调试我还记得，被我搞好了

现在看起来运行的很完美啊，感谢！我来送您小红花。我回头去研究研究正则，只要达到能用这个程序的水平就可以了，再有啥问题，再向您请教啊！谢谢！

jeros

lsdongjh 发表于 2019-6-20 13:34
代码审核中，见附件

您好，我找时间仔细研究了一下，发现目前您给的代码最后实现的category就是检索到的keyword
能麻烦帮忙改为category按照检索到的keyword，根据Keyword_category_brand表里A列和B列的对应关系所对应的category吗？
比如，检索到keyword ‘sales’，category就显示为‘Market’；检索到keyword ’Spinning off‘就是strategy。

抱歉，您的代码我还不是看的很明白，无法自己进行改动。麻烦您了！

jeros

我硬着头皮找了正则的入门材料看了下。大神，我这样理解对吗，请麻烦指导一下。谢谢！

jeros

lsdongjh 发表于 2019-6-20 13:34
代码审核中，见附件

我硬着头皮研究了一下代码，注释了一下，请您帮忙看一下我理解的对吗？谢谢！

jeros

lsdongjh 发表于 2019-6-20 13:34
代码审核中，见附件

但有些代码不是很理解，比如为什么要先trim空格然后前面加“，”，然后前后加一个空格，最后在用mid去除逗号来取值，这是出于什么考虑呢？
抱歉能力有限，请您指导。

lsdongjh

jeros 发表于 2019-6-25 08:54
但有些代码不是很理解，比如为什么要先trim空格然后前面加“，”，然后前后加一个空格，最后在用mid去除 ...

这可以说是偷懒，也可以说是技巧
初始时 strval  为空
本来可以这么写
if strval="" then
   strval=trim(objmacth)
else
   strval=strval & "," & trim(objmacth)
endif

但我不喜欢这么写，
直接用strval=strval & "," & trim(objmacth)
无非是最后去掉第一次 strval为空时的 分隔符，
strval=mid(strval,2)