大神们可否帮忙写一段删除重复文本的代码，谢谢啦

叶子h

需求： 每一行只读列匹配读写相同的文本，如果有相同的就删除只读的
    如：示例数据红字是需要删除的
         每个名字之间的间隔符号都是”；”

3190496160

Sub 删除()
With ActiveSheet
     r = .Cells(Rows.Count, 4).End(xlUp).Row
     ar = .Range("d1:f" & r)
     For i = 2 To UBound(ar)
        If ar(i, 3) <> "" Then
            If InStr(ar(i, 3), "；") > 0 Then
                rr = Split(ar(i, 3), "；")
                For s = 0 To UBound(rr)
                    If InStr(ar(i, 1), rr(s)) > 0 Then
                        ar(i, 1) = Replace(ar(i, 1), rr(s) & "；", "")
                    End If
                Next s
            Else
                If InStr(ar(i, 1), ar(i, 3)) > 0 Then
                    ar(i, 1) = Replace(ar(i, 1), ar(i, 3), "")
                End If
            End If
        End If
    Next i
    .Range("d1:f" & r) = ar
End With
MsgBox "ok!"
End Sub

3190496160

3190496160

求助删除文本.rar (19.93 KB, 下载次数: 4)

2024-1-20 10:33 上传

点击文件名下载附件

维叶

参与练习一下，楼主看下是否合适

gwjkkkkk

Option Explicit
Sub TEST5()
    Dim ar, br, i&, j&, strJoin$, dic As Object
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Range("D1", Cells(Rows.Count, "F").End(xlUp))
    For i = 2 To UBound(ar)
        dic.RemoveAll: strJoin = ""
        br = Split(ar(i, 3), "；")
        For j = 0 To UBound(br)
            dic(br(j)) = Empty
        Next j
        br = Split(ar(i, 1), "；")
        For j = 0 To UBound(br)
            If dic.exists(br(j)) = False Then
                strJoin = strJoin & "；" & br(j)
            End If
        Next j
        ar(i, 1) = Mid(strJoin, 2)
    Next i
   
    [D1].CurrentRegion.ClearContents
    [D1].Resize(UBound(ar), UBound(ar, 2)) = ar
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

字典法参与一下。。。

叶子h

3190496160 发表于 2024-1-20 10:32
Sub 删除()
With ActiveSheet
     r = .Cells(Rows.Count, 4).End(xlUp).Row

非常感谢，就是当只有一个名字的时候没有删除，就是D4单元格

叶子h

gwjkkkkk 发表于 2024-1-20 12:46
Option Explicit
Sub TEST5()
    Dim ar, br, i&, j&, strJoin$, dic As Object

收到，谢谢

叶子h

维叶 发表于 2024-1-20 10:44
参与练习一下，楼主看下是否合适

好的谢谢～