数据查找和替换

Lmbicon

各位老师好！最近由于工作业务的原因。需要对上百个这样的类似文件进行处理，越来越感觉力不从心，太多了，力不从心。所以厚着脸皮来此找找答案。寻求各位大神的帮助，希望能够在这里遇到贵人能够解决掉实际工作当中遇到的麻烦。这个问题说简单点，就是一个数据查找和替换的过程，但是实施纯属用操作效率太低，所以来寻找较为高效的办法。具体情况，详见图片，另外上传测试数据。

shiruiqiang

Sub text()
Dim arr, brr
Dim x, i
Dim dic, key
Sheets(1).Range("i2:j100000").ClearContents
arr = Sheets(1).[e1].CurrentRegion
brr = Sheets(1).UsedRange
For x = 2 To UBound(arr)
For i = 2 To UBound(brr)
If brr(i, 9) = "" Then
If InStr(brr(i, 3), arr(x, 1)) > 0 Then
brr(i, 9) = arr(x, 1)
brr(i, 10) = 1
Else
brr(i, 10) = 0
End If
End If
Next
Next
Sheets(1).UsedRange = brr
End Sub

582766

学习吧、、、、

扶摇2030

66666666666

gwjkkkkk

Sub TEST()
    Dim arr, brr, i&, j&, dic As Object, strTxt$
    Set dic = CreateObject("Scripting.Dictionary")
    arr = [E1].CurrentRegion
    For i = 2 To UBound(arr)
      dic(arr(i, 1)) = arr(i, 1)
    Next i
    arr = [A1].CurrentRegion
    ReDim Preserve arr(1 To UBound(arr), 1 To 4)
    arr(1, 4) = "代号": brr = dic.keys
    For i = 2 To UBound(arr)
       strTxt = arr(i, 3): arr(i, 3) = "": arr(i, 4) = 0
       For j = 0 To UBound(brr)
          If InStr(strTxt, brr(j)) Then
             arr(i, 3) = dic(brr(j))
             arr(i, 4) = 1
             Exit For
          End If
       Next j
    Next i
    [G1].Resize(UBound(arr), 4) = arr
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

代码审核中，请参考附件。。。

Lmbicon

gwjkkkkk 发表于 2022-11-19 18:07
代码审核中，请参考附件。。。

谢谢你。问题已经解决掉

Lmbicon

扶摇2030 发表于 2022-11-19 17:57
66666666666

谢谢，程序代码很好使

Lmbicon

shiruiqiang 发表于 2022-11-19 16:19
Sub text()
Dim arr, brr
Dim x, i

非常感谢阁下的程序代码，感谢