Excel - String Удалить дубликаты

Question

Я работаю с некоторыми данными по адресу Великобритании, которые в ячейке Excel разбиваются на составляющие части запятой.

У меня есть VBA, который я взял из Интернета, который удалил несколько точных дублированных записей, но я остался с большим количеством данных, которые повторяют сегменты последовательно, а некоторые не последовательно.

Прикрепленное изображение, выделяющее то, что я пытаюсь достичь, код, который я использовал до сих пор, который не является моим, включен, чтобы показать вам направление, в котором я искал. У кого-нибудь есть дальнейшие мысли о том, как это можно достичь?

Function stringOfUniques(inputString As String, delimiter As String) 
Dim xVal As Variant 
Dim dict As Object 
Set dict = CreateObject("Scripting.Dictionary") 

For Each xVal In Split(inputString, delimiter) 
dict(xVal) = xVal 
Next xVal 

stringOfUniques = Join(dict.Keys(), ",") 
End Function 

Это же удалось избавиться от многих из них, но есть огромное население, что я работаю так автоматизации это было бы невероятно.

Answer 1

Возможно, не самый изящный ответ, но это делает трюк. Здесь я использую команду Split для разбиения строки на каждую запятую. результат, возвращаемый из этого

bat ball banana 

Код:

Option Explicit 
Private Sub test() 
Dim Mystring As String 
Dim StrResult As String 

Mystring = "bat,ball,bat,ball,banana" 
StrResult = shed_duplicates(Mystring) 
End Sub 
Private Function shed_duplicates(ByRef Mystring As String) As String 
Dim MySplitz() As String 
Dim J As Integer 
Dim K As Integer 
Dim BooMatch As Boolean 
Dim StrTemp(10) As String ' assumes no more than 10 possible splits! 
Dim StrResult As String 


MySplitz = Split(Mystring, ",") 
    For J = 0 To UBound(MySplitz) 
    BooMatch = False 
    For K = 0 To UBound(StrTemp) 
     If MySplitz(J) = StrTemp(K) Then 
      BooMatch = True 
      Exit For 
     End If 
    Next K 
    If Not BooMatch Then 
     StrTemp(J) = MySplitz(J) 
    End If 
Next 
For J = 0 To UBound(StrTemp) 
    If Len(StrTemp(J)) > 0 Then ' ignore blank entries 
     StrResult = StrResult + StrTemp(J) + " " 
    End If 
Next J 
Debug.Print StrResult 
End Function 

Answer 2

Вы можете действительно использовать регулярное выражение замены:

^(\d*\s*([^,]*),.*)\2(,|$) 

Узор замена

$1$3 

См. regex demo. картина объяснение:

• ^ - начало строки (или строки, если .MultiLine = True)
• (\d*\s*([^,]*),.*) - Группа 1 (позже ссылка на с $1 обратной ссылки из шаблона замены) соответствия:
  • \d* - 0 + цифр с последующим
  • \s* - 0 + символы пробелов
  • ([^,]*) - Группа 2 (позже мы можем использовать в \2-шаблоне обратной ссылки, чтобы обратиться к значению захваченного с этим подмаской), соответствующим 0+, отличных от запятой
  • ,.* символов - запятая следует с 0+, кроме символа новой строки символов
• \2 - текст захвачена группа 2
• (,|$) - Группа 3 (позже привязан к с $3 из шаблона замены - восстановить запятую) соответствием либо запятой или конца строки (или строку, если .MultiLine = True).

ПРИМЕЧАНИЕ: Вам не нужно .MultiLine = True, если вы просто проверить отдельные клетки, содержащие один адрес.

Ниже приведен пример VBA Sub, показывающий, как это может быть использовано в VBA:

Sub test() 
    Dim regEx As Object 
    Set regEx = CreateObject("VBScript.RegExp") 
    With regEx 
     .pattern = "^(\d*\s*([^,]*),.*)\2(,|$)" 
     .Global = True 
     .MultiLine = True ' Remove if individual addresses are matched 
    End With 
    s = "66 LAUSANNE ROAD,LAUSANNE ROAD,HORNSEY" & vbCrLf & _ 
     "9 CARNELL LANE,CARNELL LANE,FERNWOOD" & vbCrLf & _ 
     "35 FLAT ANDERSON HEIGHTS,1001 LONDON ROAD,FLAT ANDERSON HEIGHTS" & vbCrLf & _ 
     "27 RUSSELL BANK ROAD,RUSSEL BANK,SUTTON COLDFIELD" 
    MsgBox regEx.Replace(s, "$1$3") 
End Sub 

Answer 3

Первым решением было бы использовать словарь, чтобы получить список уникальных сегментов. тогда было бы так просто, как пропуск первого номера адреса перед разбиением сегментов:

Function RemoveDuplicates1(text As String) As String 
    Static dict As Object 
    If dict Is Nothing Then 
    Set dict = CreateObject("Scripting.Dictionary") 
    dict.CompareMode = 1 ' set the case sensitivity to All 
    Else 
    dict.RemoveAll 
    End If 

    ' Get the position just after the address number 
    Dim c&, istart&, segment 
    For istart = 1 To Len(text) 
    c = Asc(Mid$(text, istart, 1)) 
    If (c < 48 Or c > 57) And c <> 32 Then Exit For ' if not [0-9 ] 
    Next 

    ' Split the segments and add each one of them to the dictionary. No need to keep 
    ' a reference to each segment since the keys are returned by order of insertion. 
    For Each segment In Split(Mid$(text, istart), ",") 
    If Len(segment) Then dict(segment) = Empty 
    Next 

    ' Return the address number and the segments by joining the keys 
    RemoveDuplicates1 = Mid$(text, 1, istart - 1) & Join(dict.keys(), ",") 
End Function 

Вторым решением было бы извлечь все сегменты, а затем поиск, если каждый из них присутствует в предыдущей позиции:

Function RemoveDuplicates2(text As String) As String 
    Dim c&, segments$, segment$, length&, ifirst&, istart&, iend& 

    ' Get the position just after the address number 
    For ifirst = 1 To Len(text) 
    c = Asc(Mid$(text, ifirst, 1)) 
    If (c < 48 Or c > 57) And c <> 32 Then Exit For ' if not [0-9 ] 
    Next 

    ' Get the segments without the address number and add a leading/trailing comma 
    segments = "," & Mid$(text, ifirst) & "," 
    istart = 1 

    ' iterate each segment 
    Do While istart < Len(segments) 

    ' Get the next segment position 
    iend = InStr(istart + 1, segments, ",") - 1 And &HFFFFFF 
    If iend - istart Then 

     ' Get the segment 
     segment = Mid$(segments, istart, iend - istart + 2) 

     ' Rewrite the segment if not present at a previous position 
     If InStr(1, segments, segment, vbTextCompare) = istart Then 
     Mid$(segments, length + 1) = segment 
     length = length + Len(segment) - 1 
     End If 
    End If 

    istart = iend + 1 
    Loop 

    ' Return the address number and the segments 
    RemoveDuplicates2 = Mid$(text, 1, ifirst - 1) & Mid$(segments, 2, length - 1) 

End Function 

И третье решение было бы использовать регулярное выражение, чтобы удалить все дублированные сегменты:

Function RemoveDuplicates3(ByVal text As String) As String 

    Static re As Object 
    If re Is Nothing Then 
    Set re = CreateObject("VBScript.RegExp") 
    re.Global = True 
    re.IgnoreCase = True 
    ' Match any duplicated segment separated by a comma. 
    ' The first segment is compared without the first digits. 
    re.Pattern = "((^\d* *|,)([^,]+)(?=,).*),\3?(?=,|$)" 
    End If 

    ' Remove each matching segment 
    Do While re.test(text) 
    text = re.Replace(text, "$1") 
    Loop 

    RemoveDuplicates3 = text 
End Function 

Они являются Время выполнения для 10000 итераций (ниже, тем лучше):

input text : "123 abc,,1 abc,abc 2,ABC,abc,a,c" 
output text : "123 abc,1 abc,abc 2,a,c" 

RemoveDuplicates1 (dictionary) : 718 ms 
RemoveDuplicates2 (text search) : 219 ms 
RemoveDuplicates3 (regex)  : 1469 ms