Удаление дубликата текста в ячейке в Excel

Question

Мне было интересно, как удалить повторяющиеся имена / текст в ячейке. Например

Jean Donea Jean Doneasee 
R.L. Foye R.L. Foyesee 
J.E. Zimmer J.E. Zimmersee 
R.P. Reed R.P. Reedsee  D.E. Munson D.E. Munsonsee 

При поиске, я наткнулся на макрос / код, это как:

Function RemoveDupes1(pWorkRng As Range) As String
'Updateby20140924
Dim xValue As String
Dim xChar As String
Dim xOutValue As String
Set xDic = CreateObject("Scripting.Dictionary")
xValue = pWorkRng.Value
For i = 1 To VBA.Len(xValue)
    xChar = VBA.Mid(xValue, i, 1)
   If xDic.exists(xChar) Then
   Else
      xDic(xChar) = ""
      xOutValue = xOutValue & xChar
   End If
Next
RemoveDupes1 = xOutValue
End Function

Макрос работает, но он сравнивает каждую букву, и если он находит повторяющиеся буквы, он удаляет это.

Когда я использую код над этими именами, результат выглядит примерно так:

Jean Dos
R.L Foyes
J.E Zimers
R.P edsDEMuno

Глядя на результат, я могу понять, что это не то, чего я хочу, но я не знаю, как исправить код.

Желаемый результат должен выглядеть следующим образом:

 Jean Donea
 R.L. Foye 
 J.E. Zimmer
 R.P. Reed 

Какие-либо предложения?

Заранее спасибо.

Answer 1

вход

С вводом на изображении:

Результат

Debug.Print выход

Regex

Регулярное выражение можно использовать динамически итерируя по ячейке, чтобы работать как инструмент поиска. Так что будет извлекаться только самое короткое совпадение. \w*( OUTPUT_OF_EXTRACTELEMENT )\w*Например: \w*(Jean)\w*

Ссылка на регулярное выражение должна быть включена.

Код

Function EXTRACTELEMENT(Txt As String, n, Separator As String) As String
    On Error GoTo ErrHandler:
    EXTRACTELEMENT = Split(Application.Trim(Mid(Txt, 1)), Separator)(n - 1)
    Exit Function
ErrHandler:
    ' error handling code
    EXTRACTELEMENT = 0
    On Error GoTo 0
End Function

Sub test()

Dim str As String
Dim objMatches As Object
Set objRegExp = CreateObject("VBScript.RegExp") 'New regexp
lastrow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
For Row = 1 To lastrow
    str = Range("A" & Row)
    F_str = ""
    N_Elements = UBound(Split(str, " "))
    If N_Elements > 0 Then
        For k = 1 To N_Elements + 1
            strPattern = "\w*(" & EXTRACTELEMENT(CStr(str), k, " ") & ")\w*"
            With objRegExp
                .Pattern = strPattern
                .Global = True
            End With
            If objRegExp.test(strPattern) Then
                Set objMatches = objRegExp.Execute(str)
                If objMatches.Count > 1 Then
                    If objRegExp.test(F_str) = False Then
                        F_str = F_str & " " & objMatches(0).Submatches(0)
                    End If
                ElseIf k <= 2 And objMatches.Count = 1 Then
                    F_str = F_str & " " & objMatches(0).Submatches(0)
                End If
            End If
        Next k
    Else
        F_str = str
    End If
    Debug.Print Trim(F_str)
Next Row

End Sub

Обратите внимание, что вы можете заменить Debug.Print записать в целевую ячейку, если это столбец B Cells(Row,2)=Trim(F_str)

объяснение

функция

Вы можете использовать этот UDF, который использует функцию Split для получения элемента, разделенного пробелами (" "). Таким образом, он может заставить каждый элемент сравнивать в ячейке.

Loops

Цикл от 1 до количества элементов k в каждой клетке и от row 1 к lastrow,

Regex

Регулярное выражение используется для поиска совпадений в ячейке и присоединения новой строки с самым коротким элементом каждого совпадения.

Answer 2

Это решение работает в предположении, что "видеть" (или какую-либо другую трехбуквенную строку) всегда будет в конце значения ячейки. Если это не так, то это не сработает.

Function RemoveDupeInCell(dString As String) As String
Dim x As Long, ct As Long
Dim str As String

'define str as half the length of the cell, minus the right three characters
str = Trim(Left(dString, WorksheetFunction.RoundUp((Len(dString) - 3) / 2, 0)))

'loop through the entire cell and count the number of instances of str
For x = 1 To Len(dString)
    If Mid(dString, x, Len(str)) = str Then ct = ct + 1
Next x

'if it's more than one, set to str, otherwise error
If ct > 1 Then
    RemoveDupeInCell = str
Else
    RemoveDupeInCell = "#N/A"
End If

End Function