Vba 在excel中删除单元格中的重复文本

我想知道如何删除单元格中重复的名称/文本。比如说

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 

有什么建议吗

---

提前感谢。

此解决方案的假设是“see”（或其他三个字母的字符串）始终位于单元格值的末尾。如果不是这样的话，这就行不通了

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

输入 使用图像上的输入：

结果

Debug.Print

输出

正则表达式 正则表达式可以在单元格上动态迭代，用作查找工具。因此，它将只提取最短的匹配<代码>\w*（提取元素的输出）\w*，例如：

\w*（Jean）\w*

正则表达式的引用必须是

代码

函数EXTRACTELEMENT（Txt作为字符串，n，分隔符作为字符串）作为字符串
错误转到错误处理程序时：
EXTRACTELEMENT=Split（Application.Trim（Mid（Txt，1）），分隔符）（n-1）
退出功能
错误处理程序：
'错误处理代码
EXTRACTELEMENT=0
错误转到0
端函数
子测试（）
作为字符串的Dim str
作为对象的Dim OBJ匹配
将objRegExp=CreateObject（“VBScript.RegExp”）”设置为新的RegExp
lastrow=ActiveSheet.Cells（ActiveSheet.Rows.Count，“A”）.End（xlUp）.Row
对于行=1到最后一行
str=范围（“A”行和行）
F_str=“”
N_Elements=UBound（拆分（str，“”）
如果N_元素>0，则
对于k=1到N_元素+1
strPattern=“\w*（“&EXTRACTELEMENT（CStr（str），k）”&“）\w*”
使用objRegExp
.Pattern=strPattern
.Global=True
以
如果是objRegExp.test（strPattern），则
设置objMatches=objRegExp.Execute（str）
如果objMatches.Count>1，则
如果objRegExp.test（F_str）=False，则
F_str=F_str&&objMatches（0）。子匹配（0）
如果结束
埃尔塞夫k
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