1

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

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

有什么建议么？

提前致谢。

4

2 回答 2

1

输入

在图像上输入：

![输入名称

结果

Debug.Print输出_

输出

正则表达式

正则表达式可用于动态迭代单元格，用作查找工具。所以它只会提取最短的匹配。\w*( OUTPUT_OF_EXTRACTELEMENT )\w*，例如：\w*(Jean)\w*

必须启用Regex 的引用。

代码

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，它使用拆分函数来获取由空格 (" ") 分隔的元素。所以它可以让每个元素在单元格上进行比较。

循环

它将从 1 循环到k每个单元格中的元素数，从 1 循环row到lastrow.

正则表达式

正则表达式用于查找单元格上的匹配项，并使用每个匹配项的最短元素加入一个新字符串。

于 2017-10-17T12:20:03.040 回答
0

此解决方案基于“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
于 2017-10-16T18:41:11.137 回答