如何批量将单元格内容中的关键字提取出来，有关键字列表

15098801898 · 发表于 2024-9-12 11:24

如何批量将单元格内容中的关键字提取出来，按关键字列表中的关键字，有的话，则将该关键字放置在相关列中。

如下图：

扇扇扇 · 发表于 2024-9-12 11:38

，，，，，，

扇扇扇 · 发表于 2024-9-12 11:42

Sub sss()

Application.ScreenUpdating = False
arr = [a1].CurrentRegion
brr = Array("美的", "华帝", "海尔", "苏泊尔", "格力", "海信", "美菱", "九阳", "帅康")
crr = Array("电热水器", "燃气热水器", "洗衣机", "烟灶套装", "净水器", "冰箱", "空调", "饮水机")
Debug.Print crr(1)
For i = 2 To UBound(arr)
For j = 0 To UBound(brr)
      If InStr(arr(i, 1), brr(j)) Then
         arr(i, 2) = brr(j)
         Exit For
      End If
Next
For j = 0 To UBound(crr)
      If InStr(arr(i, 1), crr(j)) Then
         arr(i, 3) = crr(j)
         Exit For
      End If
Next
Next
[a1].Resize(UBound(arr), UBound(arr, 2)) = arr
Application.ScreenUpdating = True

MsgBox "完成"
End Sub
附件中下标有误，已更正。

ykcbf1100 · 发表于 2024-9-12 11:45

附件供参考。。。

ykcbf1100 · 发表于 2024-9-12 11:46

参与一下。。。

Sub ykcbf() '//2024.9.12
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
With Sheets("规则")
r = .UsedRange.Find("*", , -4163, , 1, 2).Row
arr = .[a1].Resize(r, 2)
End With
For i = 2 To UBound(arr)
s = arr(i, 1)
d(s) = ""
Next
For i = 2 To UBound(arr)
s = arr(i, 2)
d1(s) = ""
Next
With Sheets("需提取数据")
r = .Cells(Rows.Count, 1).End(3).Row
arr = .[a1].Resize(r, 3)
For i = 2 To UBound(arr)
For Each k In d.keys
If InStr(arr(i, 1), k) Then
arr(i, 2) = k
Exit For
End If
Next
For Each k In d1.keys
If InStr(arr(i, 1), k) Then
arr(i, 3) = k
Exit For
End If
Next
Next
.[a1].Resize(r, 3) = arr
End With
Set d = Nothing
Set d1 = Nothing
MsgBox "OK！"
End Sub

复制代码

taller · 发表于 2024-9-12 11:49

taller · 发表于 2024-9-12 11:51

Sub Demo()
Dim i as Long, j as Long, k as Long
Dim arrData, rngData as Range
Dim arrRes, iR as Long, sVal As String
Dim LastRow as Long, arrGZ
Dim oSht1 As Worksheet, oSht2 As Worksheet
Set oSht1 = Sheets(1)
Set oSht2 = Sheets(2)
Set rngData = oSht1.Range("A1").CurrentRegion
arrData = rngData.Value
arrGZ = oSht2.Range("A1").CurrentRegion.Value
iR = UBound(arrGZ)
For i = LBound(arrData)+1 To UBound(arrData)
sVal = arrData(i, 1)
For k =1 to 2
For j = 2 To iR
If Len(arrGZ(j,k))>0 Then
If Instr(sVal, arrGZ(j,k))>0 Then
arrData(i, k+1) = arrGZ(j,k)
End If
End If
Next j
Next k
Next i
rngData.Value = arrData
End Sub

复制代码

joy.008@163.com · 发表于 2024-9-12 13:42

Sub joycc() 'https://club.excelhome.net/thread-1701563-1-1.html?_dsign=ba52a7ef
Dim arr, i%, S1$, S2$, SS
arr = Sheet2.Range("A2:A" & Sheet2.Range("A" & Cells.Rows.Count).End(xlUp).Row)
For i = 1 To UBound(arr)
S1 = S1 & "|" & arr(i, 1)
Next
S1 = Mid(S1, 2)
arr = Sheet2.Range("B2:B" & Sheet2.Range("B" & Cells.Rows.Count).End(xlUp).Row)
For i = 1 To UBound(arr)
S2 = S2 & "|" & arr(i, 1)
Next
S2 = Mid(S2, 2)
arr = Sheet1.Range("A1").CurrentRegion
With CreateObject("vbscript.regexp")
.Global = True
For i = 2 To UBound(arr)
.Pattern = S1
If .test(arr(i, 1)) Then
Set SS = .Execute(arr(i, 1))
arr(i, 2) = .Execute(arr(i, 1))(0)
End If
.Pattern = S2
If .test(arr(i, 1)) Then arr(i, 3) = .Execute(arr(i, 1))(0)
Next
End With
Sheet1.Range("A1").CurrentRegion = arr
End Sub

复制代码

joy.008@163.com · 发表于 2024-9-12 13:43

joy.008@163.com · 发表于 2024-9-12 13:44

正则试一下

		自动登录	找回密码
密码			免费注册

[求助] 如何批量将单元格内容中的关键字提取出来，有关键字列表

评分

评分