[已解决]高手给看一看 宏有什么错误呀!

dong66094799

高手看一看.rar (127.33 KB, 下载次数: 8)

2011-8-18 22:19 上传

点击文件名下载附件
看一看 谢谢

最佳答案

月排行榜 / 总排行榜

放浪形骸

2011-8-18 22:54

那现在给你加一条语句就可以了：

1. Sub 高级筛选1()
   
2.     With Sheets("Sheet1")
   
3.         Dim arr, n As Double, dic As New Dictionary, brr()
   
4.         n = .Range("a65536").End(xlUp).Row
   
5.         arr = .Range("a1:b" & n)
   
6.         For i = 1 To UBound(arr)
   
7.             If dic.Exists(arr(i, 2)) Then
   
8.                 m = m + 1
   
9.                 ReDim Preserve brr(1 To 2, 1 To m)
   
10.                 brr(1, m) = arr(i, 1): brr(2, m) = arr(i, 2)
    
11.             Else
    
12.                 dic(arr(i, 2)) = arr(i, 1)
    
13.             End If
    
14.         Next
    
15.         .Range("e:f").ClearContents
    
16.         .Range("e1:f1") = Array("姓名", "身份证号")
    
17.         On Error Resume Next
    
18.         .Range("e2").Resize(m, 2) = Application.Transpose(brr) 'E、F列放身份证号有重复的
    
19.         .Range("c:d").ClearContents
    
20.         .Range("c1").Resize(dic.Count) = Application.Transpose(dic.Items) 'C列、D列放不重复值
    
21.         .Range("d1").Resize(dic.Count) = Application.Transpose(dic.Keys)
    
22.     End With
    
23. End Sub

复制代码

On Error Resume Next
出错了之后继续接下来的程序，就OK了。
你试下

跳转到最佳答案楼层

放浪形骸

你A,B列里根本就没有数据某。

放浪形骸

A列B列放好数据就可以运行了啊。。。

放浪形骸

我运行好的结果：

dong66094799

我在A B列放置数据了,运行结果也显示这样的结果

dong66094799

回复 放浪形骸 的帖子

高级筛选(1).rar (140.29 KB, 下载次数: 2)

2011-8-18 22:37 上传

点击文件名下载附件
请 放浪形骸 看看 其他人不要看 谢谢

lisachen

代码没有错误
当第二行没有数据时
brr为没数据
所以会出现错误、
当第二行没有数据时不为空时
运行正常

放浪形骸

哦，我刚才看错了。
应该是这样的：

1. Sub 高级筛选1()
   
2.     With Sheets("Sheet1")
   
3.         Dim arr, n As Double, dic As New Dictionary, brr()
   
4.         n = .Range("a65536").End(xlUp).Row
   
5.         arr = .Range("a1:b" & n)
   
6.         For i = 1 To UBound(arr)
   
7.             If dic.Exists(arr(i, 2)) Then
   
8.                 m = m + 1
   
9.                 ReDim Preserve brr(1 To 2, 1 To m)
   
10.                 brr(1, m) = arr(i, 1): brr(2, m) = arr(i, 2)
    
11.             Else
    
12.                 dic(arr(i, 2)) = arr(i, 1)
    
13.             End If
    
14.         Next
    
15.         .Range("e:f").ClearContents
    
16.         .Range("e1:f1") = Array("姓名", "身份证号")
    
17.         .Range("e2").Resize(m, 2) = Application.Transpose(brr) 'E、F列放身份证号有重复的
    
18.         .Range("c:d").ClearContents
    
19.         .Range("c1").Resize(dic.Count) = Application.Transpose(dic.Items) 'C列、D列放不重复值
    
20.         .Range("d1").Resize(dic.Count) = Application.Transpose(dic.Keys)
    
21.     End With
    
22. End Sub

复制代码

把中间的循环判断中的if成立时的

1. brr(1, m) = dic(arr(i, 2))

复制代码

改成

1. brr(1, m) = arr(i, 1)

复制代码

因为这时候brr里需要存储的是同样的身份证号对应的不同的名字

dong66094799

我想做到 A B列有数据时筛选,并在E F列显示出所有A B列重复数据而不是只显示一个重复数据
例如AB列 张三 37010119740416001X 张三 37010119740416001X 二条数据重复,这个宏在EF列只能显示一条重复 我想显示所有重复数据 能做到吗? 请高手指教!谢谢

dong66094799

Sub 高级筛选1()

    With Sheets("Sheet1")

        Dim arr, n As Double, dic As New Dictionary, brr()

        n = .Range("a65536").End(xlUp).Row

        arr = .Range("a1:b" & n)

        For i = 1 To UBound(arr)

            If dic.Exists(arr(i, 2)) Then

                m = m + 1

                ReDim Preserve brr(1 To 2, 1 To m)

                brr(1, m) = arr(i, 1): brr(2, m) = arr(i, 2)

            Else

                dic(arr(i, 2)) = arr(i, 1)

            End If

        Next

        .Range("e:f").ClearContents

        .Range("e1:f1") = Array("姓名", "身份证号")

        .Range("e2").Resize(m, 2) = Application.Transpose(brr) 'E、F列放身份证号有重复的

        .Range("c:d").ClearContents

        .Range("c1").Resize(dic.Count) = Application.Transpose(dic.Items) 'C列、D列放不重复值

        .Range("d1").Resize(dic.Count) = Application.Transpose(dic.Keys)

    End With

End Sub

我代码复制宏内了 还不好使呀?