自动提取不重复的项，带点模糊查找和出去重复项的问题

njwtg · 发表于 2022-12-15 16:48

请问老师，我想自动提取不重复的项，带点模糊查找和出去重复项的问题，程序的思路比较饶人，分3个步骤来表述：
1、“明细表“中I列有关键词【用于-*】时，就提取H和I列的数据，如本表J和K列所示
2、清除关键词“】”后面的文字，如本表M和N列所示
3、清除重复值，如本表P和Q列所示
4、上述演示的效果放在本表的B列和C列

ykcbf1100 · 发表于 2022-12-15 16:54

做个标记，明天看下吧

feilanga · 发表于 2022-12-15 17:31

Sub hz()
arr = Sheet1.UsedRange
Dim dic As Object
Set dic = CreateObject("scripting.dictionary")
For i = 2 To UBound(arr)
If arr(i, 9) <> Empty Then
If InStr(arr(i, 9), "用于") > 0 Then
名称 = arr(i, 8)
x = InStr(1, arr(i, 9), "】")
用处 = Left(arr(i, 9), x)
Key = 名称 & "|" & 用处
dic(Key) = i
End If
End If
Next
keys = dic.keys
ReDim brr(1 To dic.Count, 1 To 2)
For i = 0 To dic.Count - 1
k = k + 1
temp = Split(keys(i), "|")
brr(k, 1) = temp(0)
brr(k, 2) = temp(1)
Next
Sheet2.Range("B2:C" & Rows.Count).ClearContents
Sheet2.Range("B2").Resize(k, 2) = brr
End Sub

复制代码

njwtg · 发表于 2022-12-15 20:01

完美，一次点亮，谢谢feilanga老师

gwjkkkkk · 发表于 2022-12-15 20:35

请楼主参考附件。。。

gwjkkkkk · 发表于 2022-12-15 20:46

再简洁一点。。。

leirongqin · 发表于 2022-12-16 11:19

Sub 一键查找复制()
Dim d As Object, arr, i&
Set d = CreateObject("scripting.dictionary")
arr = Sheet1.UsedRange
For i = 1 To UBound(arr)
If InStr(arr(i, 9), "】") > 0 Then
d((arr(i, 8)) & Left(arr(i, 9), WorksheetFunction.Find("】", arr(i, 9)))) = arr(i, 8) & "|" & Left(arr(i, 9), WorksheetFunction.Find("】", arr(i, 9)))
End If
Next
ReDim brr(1 To d.Count, 1 To 2)
For i = 0 To d.Count - 1
ss = d.Items
temp = Split(ss(i), "|")
brr(i + 1, 1) = temp(0)
brr(i + 1, 2) = temp(1)
Next
Sheet2.Range("B2:C10000").ClearContents
Sheet2.Range("B2").Resize(d.Count, 2) = brr
Set d = Nothing
End Sub

复制代码

我也练习一下，

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

[求助] 自动提取不重复的项，带点模糊查找和出去重复项的问题

评分

评分