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

jeros

lsdongjh 发表于 2019-6-25 10:03
这可以说是偷懒，也可以说是技巧
初始时 strval  为空
本来可以这么写

嗯，这个明白了。

我实际运行的时候发现一个问题，就是Brand和keyword在标题里发现几次的话，它最后就会重复几次显示，比如‘sales,sales,sales'，这个怎么把它去重？
我知道可能需要使用正则元字符，但我不知道怎么把这个需求整合到您的代码中去，能麻烦您帮个忙教教我吗？
谢谢！

lsdongjh

用字典去重

jeros

lsdongjh 发表于 2019-6-25 16:17
用字典去重

复杂吗? 有没有啥例子可以看看，我完全不会。
这两天我研究正则已经头晕眼花了，勉强看了个半饱。

zopey

这题用正则匹配并不合适 ，上百个关键字 全放到一个表达式中？
所以字典匹配更方便。

jeros

zopey 发表于 2019-6-25 20:40
这题用正则匹配并不合适 ，上百个关键字 全放到一个表达式中？
所以字典匹配更方便。

那我回头再看看字典相关知识（又是满头包，你们搞搞十几分钟，我估计得几天，哈哈）
您能就去重那个给个例子吗？
需求很简单，就是有一列，每一个单元格里都有例如‘sales，sales，sales’的字符，格式一样，两头无空格，中间逗号隔开。要求去重。
我就想看个例子我好对照着去找资料学习下字典。。。谢谢啊~

jeros

不过蛮好的，通过这个例子又明白了一些新知识。:)

jeros

lsdongjh 发表于 2019-6-25 16:17
用字典去重

今天又发现一个问题，如果标题里存在类似这样的语句：...sales market... 而sales和market又都是keyword的话，第二个词market就会无法检索到，这个有什么方便的方法改一下代码就可以修正吗？

感谢您一直指导我，谢谢！

lsdongjh

修正了一下：
1、不再采用空格符，直接用单词边界
2、用字典去重

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

复制代码

lsdongjh

修正：
1、用边界符
2、字典去重
见附件： News to Columns.rar (52.32 KB, 下载次数: 15)

2019-6-26 12:50 上传

点击文件名下载附件

jeros

lsdongjh 发表于 2019-6-26 12:50
修正：
1、用边界符
2、字典去重

太感谢了，感激涕零，马上去研究下，突然想起公司电脑自动会删除文件含marco的部分。。。sigh。。。
我回家看吧，艾玛想搞个东西真累。或者可以麻烦您把代码贴出来那我上班就能研究了。
感谢大神。