- Option Explicit
- Sub TEST()
- Dim i%, arr, brr(), n, k, d As Object, crr
- arr = [a1].CurrentRegion
- crr = [a1].CurrentRegion
- Application.ScreenUpdating = False
- For i = 1 To UBound(arr)
- n = InStr(arr(i, 2), "公司")
- If n > 0 Then
- arr(i, 2) = Left(arr(i, 2), n - 1) & Right(arr(i, 2), Len(arr(i, 2)) - n - 1)
- End If
- n = InStr(arr(i, 2), "有限")
- If n > 0 Then
- arr(i, 2) = Left(arr(i, 2), n - 1) & Right(arr(i, 2), Len(arr(i, 2)) - n - 1)
- End If
- n = InStr(arr(i, 2), "责任")
- If n > 0 Then
- arr(i, 2) = Left(arr(i, 2), n - 1) & Right(arr(i, 2), Len(arr(i, 2)) - n - 1)
- End If
- Next
- [a1].CurrentRegion = arr
- n = 0
- Set d = CreateObject("Scripting.Dictionary")
- arr = [a1].CurrentRegion
- For i = 1 To UBound(arr)
- If Not d.exists(arr(i, 2)) Then
- d(arr(i, 2)) = ""
- n = n + 1
- ReDim Preserve brr(1 To 5, 1 To n)
- brr(1, n) = n: brr(2, n) = arr(i, 2) & "有限责任公司": brr(3, n) = arr(i, 3): brr(4, n) = arr(i, 4): brr(5, n) = arr(i, 5)
- End If
- Next
- [a10].Resize(n, 5) = Application.Transpose(brr)
- [a1].CurrentRegion = crr
- Application.ScreenUpdating = True
- End Sub
复制代码 曾几何时也遇到此问题,数据量很大,名称五花八门,当时是这样解决的,把可能重复的值都列出来。然后只把关键字取出,然后进行判断,当然可能列不尽 所以正确率大概也只有80%左右,根据你的附近就是这样的。。 |