(重复记录问题)

该过程对区域里每个单元格进行对比,如下:

1,2,2,4,5,6,7

那么会返回2,因为它有重复

同理由:1,2,2,4,5,6,7,7

那么返回2,7

在测试的时候我发现,所选区域的单元格较少的情况下,能正确返回结果,但是如果记录在10000多,象"ASDFSDFASDFASDFASDF"和"ASDFSDFASDFASDFASDF-1"这样的两条记录,会被认为是相同的.从而返回"ASDFSDFASDFASDFASDF"

我非常疑惑,请高手指点:是否数组越界或者其他原因造成的,请给个处理意见!谢谢!

Sub RngChongFu()
 Dim rng As Range, arr() As Variant, arr1() As Variant, arr2() As Variant, s As String
 Dim myPrompt As String
 Dim myTitle As String
 Dim i As Long, m As Long, k As Long, j As Long, n As Long, a As Long
 
 On Error GoTo line
 myPrompt = "请使用鼠标选择需要筛选出重复记录的单元格区域"
 myTitle = "区域选择"
 Set rng = Application.InputBox(prompt:=myPrompt, Title:=myTitle, Type:=8)
 n = Application.WorksheetFunction.CountA(rng)
 '============================
   '取区域内的非空值，存储到数组
 ReDim arr(1 To n)
 For i = 1 To rng.Cells.Count
  If Len(rng.Cells(i)) > 0 Then
  m = m + 1
  arr(m) = rng(i)
  End If
  Next i

 '============================
 'Filter函数计算每个元素出现的次数，大于1的挑选出来
 m = UBound(arr)
 ReDim arr1(1 To m)
 j = 0
 For i = 1 To m
 k = UBound(Filter(arr, arr(i))) + 1
  If k > 1 Then
 's = s & arr(i) & vbCr
  j = j + 1
  arr1(j) = arr(i)
 
    End If
 
 Next i
 
 If j > 1 Then
 rng.ClearContents

  '============================
   '重复值置空
  For i = 1 To j - 1
  If Len(arr1(i)) > 0 Then
   For n = i + 1 To j
    If arr1(i) = arr1(n) Then
    arr1(n) = ""
    End If
   
    Next n
  End If
 
 Next i
  '============================
  ReDim arr2(1 To j)
  a = 0
  For i = 1 To j
   If Len(arr1(i)) > 0 Then
   a = a + 1
   arr2(a) = arr1(i)
  
   End If
 
  Next i
    '============================
    For i = 1 To a
    rng(i) = arr2(i)
    Next i
 
  
  MsgBox "在所选择区域共有" & a & "个重复记录，结果已经显示在所选择区域"
  Else
  MsgBox "所选择区域没有重复记录"
 
 
 
  
 
 End If

line:

End Sub

请澄清一下“重复记录”的概念。一般认为，一行就是一个记录。两行间同列单元格完全相同的视为重复。

该过程对区域里每个单元格进行对比,如下:

1,2,2,4,5,6,7

那么会返回2,因为它有重复

同理由:1,2,2,4,5,6,7,7

那么返回2,7

在测试的时候我发现,所选区域的单元格较少的情况下,能正确返回结果,但是如果记录在10000多,象"ASDFSDFASDFASDFASDF"和"ASDFSDFASDFASDFASDF-1"这样的两条记录,会被认为是相同的.从而返回"ASDFSDFASDFASDFASDF"

对,你看,我的程序,哪里存在问题?

筛选数据量较大的时候,就出现我所描述的情况

还搞不清楚为什么这么简单的问题要弄那么复杂的程序，我先试试能否看懂。

Sub RngChongFu()
    Dim rng, rg, cf As Range
    Set rng = Application.InputBox(prompt:="请用鼠标选择查找重复记录区域", Type:=8)
    For Each rg In rng
        If Not IsEmpty(rg) Then _
            If Application.CountIf(rng, rg) > 1 Then rg.Font.ColorIndex = 3
    Next rg
End Sub

 看程序太费劲，还是从头编好。不过我是将重复的数据变成红字。(见了8楼的程序又学习改进了一下）

我是菜鸟，就是进来看看

怎么没有附件，让我也学习一下

我自己测试了一下，并没有产生这样的问题：

Option Explicit

Sub 随机产生记录() '为方便测试，随机产生10001条记录
Dim arr(10000, 0), i&
Randomize
For i = 0 To 10000
arr(i, 0) = "ASDFSDFASDFASDFASDF" & Int(Rnd * 100000 + 1)
Next
Range("a1:a10001") = arr
End Sub
Sub 查找重复()
Dim rg As Range, rng As Range, tm
Application.ScreenUpdating = 0
tm = Timer
Set rng = Range("a1:a10001")
For Each rg In rng
If Application.CountIf(rng, rg) > 1 Then rg.Font.ColorIndex = 3
Next
Application.ScreenUpdating = 1
MsgBox "完成任务，用时 " & Timer - tm & " 秒", 64
End Sub

字典也是满不错的

Sub RngChongFu()
    Set d = CreateObject("scripting.dictionary")
    Dim rng, rg, cf As Range
    Set rng = Application.InputBox(prompt:="请用鼠标选择查找重复记录区域", Type:=8)
    For Each rg In rng
        If Not IsEmpty(rg) Then
            v = "*" & rg.Value
            d(v) = d(v) + 1
        End If
    Next rg
    rng.ClearContents
    k = d.keys
    x = 1
    For i = 0 To d.Count - 1
        If d(k(i)) > 1 Then
            rng(x).Value = Mid(k(i), 2)
            x = x + 1
        End If
    Next i
End Sub