多条件区域删除重复行

529905149

多条件区域删除重复行

Kaohsing

用字典比较方便

jsgj2023

Sub Adele()
    Dim d As Object, rng As Range
    On Error Resume Next
    Set d = CreateObject("scripting.dictionary")
    With Worksheets("Sheet1")
        r = .Cells(Rows.Count, 1).End(xlUp).Row
        arr = .Range("a1:k" & r)
        For x = 2 To UBound(arr)
            s = arr(x, 2) & "+" & arr(x, 3) & "+" & arr(x, 4) & "+" & arr(x, 5) _
            & "+" & arr(x, 6) & "+" & arr(x, 7) & "+" & arr(x, 8) & "+" & arr(x, 9) & "+" & arr(x, 10)
            If Not d.exists(s) Then
                d(s) = ""
            Else
                If rng Is Nothing Then
                    Set rng = .Rows(x)
                Else
                    Set rng = Union(rng, .Rows(x))
                End If
                If Not rng Is Nothing Then
                    rng.Delete
                End If
            End If
        Next x
    End With
End Sub

jsgj2023

Sub Adele()

529905149

jsgj2023 发表于 2017-2-11 14:12
Sub Adele()

谢谢您的解答，但是VBA运行完会自动关闭表格

jsgj2023

Sub Adele()
    Dim d As Object, rng As Range
    On Error Resume Next
    Set d = CreateObject("scripting.dictionary")
    With Worksheets("Sheet1")
        r = .Cells(Rows.Count, 1).End(xlUp).Row
        arr = .Range("a1:k" & r)
        For x = 2 To UBound(arr)
            s = arr(x, 2) & "+" & arr(x, 3) & "+" & arr(x, 4) & "+" & arr(x, 5) _
            & "+" & arr(x, 6) & "+" & arr(x, 7) & "+" & arr(x, 8) & "+" & arr(x, 9) & "+" & arr(x, 10)
            If Not d.exists(s) Then
                d(s) = ""
            Else
                If rng Is Nothing Then
                    Set rng = .Rows(x)
                Else
                    Set rng = Union(rng, .Rows(x))
                End If
            End If
        Next x
         If Not rng Is Nothing Then
            rng.Delete
        End If
    End With
End Sub

529905149

Kaohsing 发表于 2017-2-11 12:45
用字典比较方便

谢谢您的解答，如果是从A列到K列删除重复行呢？

jsgj2023

s =arr(x,1) & "+" & arr(x, 2) & "+" & arr(x, 3) & "+" & arr(x, 4) & "+" & arr(x, 5) _
             & "+" & arr(x, 6) & "+" & arr(x, 7) & "+" & arr(x, 8) & "+" & arr(x, 9) & "+" & arr(x, 10)

529905149

s =arr(x,1) & "+" & arr(x, 2) & "+" & arr(x, 3) & "+" & arr(x, 4) & "+" & arr(x, 5) _
             & "+" & arr(x, 6) & "+" & arr(x, 7) & "+" & arr(x, 8) & "+" & arr(x, 9) & "+" & arr(x, 10) & "+" & arr(x, 11)

lsc900707

529905149 发表于 2017-2-11 16:01
谢谢您的解答，如果是从A列到K列删除重复行呢？

Sub lsc()
    Dim d As Object, Rng As Range
    Set d = CreateObject("scripting.dictionary")
    With Sheet1
        arr = .[a1].CurrentRegion
        For i = 2 To UBound(arr)
            s = arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4) & "," & arr(i, 5) _
            & "," & arr(i, 6) & "," & arr(i, 7) & "," & arr(i, 8) & "," & arr(i, 9) & "," & arr(i, 10)
            If Not d.exists(s) Then
                d(s) = ""
            Else
                If Rng Is Nothing Then
                    Set Rng = .Rows(i)
                Else
                    Set Rng = Union(Rng, .Rows(i))
                End If
            End If
        Next
        If Not Rng Is Nothing Then Rng.Delete
    End With
End Sub