这个循环多按一下就出现错误，有没哪位大神帮忙下

lwlhong

Sub test()
Application.ScreenUpdating = False

Dim arr, brr(), a As Range

Set dic = CreateObject("scripting.dictionary")
arr = Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row)
For i = 1 To UBound(arr)
     x = arr(i, 2) & "," & arr(i, 3)
     If dic.exists(x) Then
         m = m + 1
         ReDim Preserve brr(1 To m)
         brr(m) = i
     Else
         dic(x) = 0
     End If
Next

For j = 1 To UBound(brr)
     If a Is Nothing Then
         Set a = Rows(brr(j))
     Else
         Set a = Union(a, Rows(brr(j)))
     End If
     

Next
a.Delete

End Sub

wxxydl

传附件  别人才能帮你看

liulang0808

楼主在报错的时候，如果有调试，看看哪一行报错的
a.Delete 如果没有满足删除的行，这个是要报错的

Manrce

如果没别的影响直接加
ON ERROR RESUME NEXT
先保证使用

网海遨游

楼主的意思是：对于x=arr(i,2)&arr(i,3)，多个相同的保留一行，其他的都删除？



楼主最好是上传个附件，他人能更好地帮到你。

网海遨游

看了你那个帖子原件，试试


Sub test()
Application.ScreenUpdating = False
Dim arr, brr(1 to 10000,1 to 3), n%,i%,j%
Set d= CreateObject("scripting.dictionary")
arr = [a1].currentregion.resize(,3)
For i = 1 To UBound(arr)
     x = arr(i, 2) & "," & arr(i, 3)
if not d.exists(x) then
        d(x)=""
        n=n+1
        for j=2 to 3
              brr(n,j)=arr(i,j)
          next j
       end if
next i
range("e:f").clearcontents
[e1].resize(ubound(brr),2)=brr
Application.ScreenUpdating =true
end sub

lwlhong

网海遨游 发表于 2020-1-19 17:56
看了你那个帖子原件，试试

不行，你这个是删除列的吧，我是要删除行的

lwlhong

我就是运行第一次能删除重复的，运行第二次，就是重复的行删除完了以后，就出现了错误