VBA возможный дубликат проверки - PullRequest
Новая
       20

VBA возможный дубликат проверки

0 голосов
/ 03 июня 2018

У меня есть список поставщиков, и я хочу проверить их, чтобы увидеть, есть ли возможные дубликаты.

Давайте рассмотрим несколько примеров имен поставщиков: 

1. The Supplier GmbH
2. Trading Company LLC & Co. KG
3. DHL Express
4. DHL-Express Inc.
5. Supplier GmbH
6. Trading S.a.r.l.

Я создал две функции регулярных выражений: StripNonAlpha, которая удаляет все не буквенные символы и двухбуквенные слова и заменяет "-" пробелом иWordMatch, который принимает два аргумента и возвращает True, если это конкретное слово существует в названии компании (я хочу проверить целые слова, а не частичные, поэтому я не использую InStr).

Исходя из названий поставщиков сверху, я хочу, чтобы, например, поставщики 1 и 5, 3 и 4 отмечались как возможные дубликаты, но не 2 и 6.

У меня есть около 100 000 поставщиков для проверки, но кодработает очень медленноЛюбые подсказки, как это оптимизировать? 

Function StripNonAlpha(TextToReplace As String) As String

Dim ObjRegex As Object
Set ObjRegex = CreateObject("vbscript.regexp")

With ObjRegex
    .Global = True
    .Pattern = "[^a-zA-Z\s]+"
    StripNonAlpha = .Replace(Replace(TextToReplace, "-", Chr(32)), vbNullString)
    .Pattern = "\b.{2}\b"
    StripNonAlpha = .Replace(StripNonAlpha, vbNullString)
End With

End Function

Function WordMatch(Source As String, MatchExprValue As String) As Boolean

    Dim RE As Object
    Set RE = CreateObject("vbscript.regexp")

    RE.IgnoreCase = True
    RE.Pattern = "\b" & MatchExprValue & "\b"
    WordMatch = RE.test(Source)

End Function

Sub possible_duplicatev2()

Dim arr1() As String
Dim exclude(1 To 6) As String
Dim arr2() As String
Dim companyname As Range
Dim i As Long
Dim j As Long
Dim k As Long
Dim l As Long
Dim FoundCount As Long
Dim DuplicateCount As Long
Dim rc As Long
Dim scompanyname As String
Dim x As Long
Dim y As Long

exclude(1) = "sarl"
exclude(2) = "gmbh"
exclude(3) = "llc"
exclude(4) = "inc"
exclude(5) = "the"
exclude(6) = "sas"

rc = Range("A" & Rows.Count).End(xlUp).Row

For x = rc To 2 Step -1
    If LCase(Range("B" & x).Text) Like "*zzz*" Or LCase(Range("B" & x).Text) Like "*xxx*" Or LCase(Range("B" & x).Text) Like "*yyy*" Then
        Range("B" & x).EntireRow.Delete
    End If
Next x


rc = Range("A" & Rows.Count).End(xlUp).Row - 1
ReDim arr1(1 To rc, 1 To 2)

    For Each companyname In Range("B2", Range("B1").End(xlDown))
        scompanyname = StripNonAlpha(LCase(companyname))
        arr1(companyname.Row - 1, 1) = scompanyname
    Next companyname


    For i = 1 To UBound(arr1, 1)

        For j = 1 To UBound(exclude)
            If WordMatch(arr1(i, 1), exclude(j)) = True Then
                Replace arr1(i, 1), exclude(j), ""
            End If
        Next j

        arr2 = Split(arr1(i, 1), " ")
            For k = 1 To UBound(arr1, 1)
                For l = 0 To UBound(arr2)
                    If k = i Then
                        GoTo nextk
                    ElseIf WordMatch(arr1(k, 1), arr2(l)) = True Then
                        FoundCount = FoundCount + 1
                    End If
                Next l
                If UBound(arr2) = 1 And FoundCount = 1 Then
                    arr1(k, 2) = "Yes"
                    DuplicateCount = DuplicateCount + 1
                ElseIf UBound(arr2) > 0 And FoundCount > 1 Then
                    arr1(k, 2) = "Yes"
                    DuplicateCount = DuplicateCount + 1
                Else
                    arr1(k, 2) = "No"
                End If
                FoundCount = 0
            nextk:
            Next k
            If DuplicateCount > 0 Then
                arr1(i, 2) = "Yes"
            Else
                arr1(i, 2) = "No"
            End If
            DuplicateCount = 0
    Next i

For y = 1 To UBound(arr1, 1)
    Range("D" & y + 1) = arr1(y, 2)
Next y

End Sub
...