|
多年后看到这个题,尽管是修改过的代码还是有些冗余的地方。
这样好看多了。。。
- Sub a()
- '转换
- ar = Sheet1.[a1].CurrentRegion.Value
- Set d = CreateObject("scripting.dictionary")
- Set re = CreateObject("vbscript.regexp")
- re.Pattern = "[\((]\d+人?[\))]"
- For i = 65 To 72
- d(d.Count + 1) = Chr(i)
- Next
- For i = 1 To UBound(ar)
- s = ar(i, 1)
- If re.Execute(s).Count > 0 Then
- gs = re.Replace(Mid(s, InStr(s, ".") + 1), "")
- Do
- i = i + 1
- If i > UBound(ar) Then Exit For
- ss = ar(i, 1)
- If re.Execute(ss).Count = 0 Then
- For n = 1 To UBound(ar, 2)
- sss = Trim(ar(i, n))
- If Len(sss) Then
- If Not d.exists(sss) Then
- d(sss) = Array(d(n) & i, gs)
- Else
- d(sss) = Array(d(sss)(0) & "、" & d(n) & i, d(sss)(1) & "、" & gs)
- End If
- End If
- Next
- Else
- i = i - 1
- Exit Do
- End If
- Loop
- End If
- Next
- '匹配
- Sheet2.[a1].CurrentRegion.Offset(2, 10).Resize(, 2).ClearContents
- br = Sheet2.[a1].CurrentRegion
- For i = 3 To UBound(br)
- s = Trim(br(i, 4))
- If d.exists(s) Then
- br(i, 11) = "表1中" & d(s)(0)
- br(i, 12) = d(s)(1)
- Else
- br(i, 11) = "未查到"
- End If
- Next
- Sheet2.[a1].CurrentRegion = br
- End Sub
复制代码 |
评分
-
1
查看全部评分
-
|