这个用VBA要怎么做呢

woods002000 · 发表于 2020-12-1 09:01

RT想了好久想不出来

hongshan2019 · 发表于 2020-12-1 09:04

思路：做字典，简单的包含关系判断。赋值。

约定的童话 · 发表于 2020-12-1 09:26

等分的标准在哪？

Chip_Kenny · 发表于 2020-12-1 09:32

Sub zz()
Dim a, d As Object, rexp As Object, i&, r&
Set rexp = CreateObject("vbscript.regexp")
Set d = CreateObject("scripting.dictionary")
a = [a2].CurrentRegion.Value
For i = 1 To UBound(a)
d(a(i, 1)) = a(i, 2)
Next
r = [f1048576].End(3).Row
b = Range("f2:f" & r).Value
Range("f2:f" & r).Offset(, 1).Clear
With rexp
.Pattern = "([\u4e00-\u9fa5]+).*"
For i = 1 To UBound(b)
b(i, 1) = d(.Replace(b(i, 1), "$1"))
Next
[g2:g17].Value = b
End With
End Sub

复制代码

3190496160 · 发表于 2020-12-1 09:32

Sub test()
Set d = CreateObject("scripting.dictionary")
With Sheet1
r = .Cells(Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:b" & r)
rs = .Cells(Rows.Count, 6).End(xlUp).Row
.Range("g2:g" & rs + 1).ClearContents
br = .Range("f2:g" & rs)
For i = 2 To UBound(ar)
      If Trim(ar(i, 1)) <> "" Then
         d(Trim(ar(i, 1))) = ar(i, 2)
      End If
Next i
For i = 1 To UBound(br)
      If Trim(br(i, 1)) <> "" Then
         For s = 2 To UBound(ar)
            If InStr(br(i, 1), ar(s, 1)) > 0 Then
                  br(i, 2) = ar(s, 2)
                  Exit For
            End If
         Next s
      End If
Next i
   .Range("f2:g" & rs) = br
End With
End Sub