查询重复次数

一把小刀闯天下

lrh788 发表于 2018-6-7 15:07
老师，你的代码中，哪个语句有排序功能

'变得复杂很多，也毫无意义
'没有排序功能。19楼中已作说明，你自己的帖子你都不知道？
'觉得你是在玩而不是在学，特别嗨是吧。

Option Explicit

Sub test()
  Dim i As Long, j As Long, k As Long, n As Long, arr, dt, flag As Boolean, m As Long
  Application.ScreenUpdating = False
  dt = Timer
  arr = Range("a3:c" & Cells(Rows.Count, "a").End(xlUp).Row + 1)
  arr(UBound(arr, 1), 1) = "ABC": arr(UBound(arr, 1), 1) = "ABC": arr(UBound(arr, 1), 1) = "ABC"
  ReDim brr(1 To UBound(arr, 1), 1 To 1) As String
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      m = 0: flag = False
      For k = 1 To 3
        If Len(arr(j, k)) = 0 Then
          m = m + 1
        Else
          If Len(arr(j + 1, k)) > 0 Then
            If arr(j, k) <> arr(j + 1, k) Then flag = True ': Exit For
          End If
        End If
      Next
      If flag Or m > 1 Then
        If j > i Then
          n = 0
          For k = i To j
            brr(k, 1) = "重复" & n: n = n + 1
          Next
          If m > 1 Then brr(j, 1) = "唯一"
        Else
          brr(j, 1) = "唯一"
        End If
        i = j: Exit For
      End If
  Next j, i
  [d3].Resize(UBound(brr, 1)) = brr
  Debug.Print Timer - dt
  Application.ScreenUpdating = True
End Sub

lrh788

一把小刀闯天下 发表于 2018-6-7 15:51
'变得复杂很多，也毫无意义
'没有排序功能。19楼中已作说明，你自己的帖子你都不知道？
'觉得你是在玩 ...

老师，我真不是玩，我工作中的确遇到这样的问题！感谢老师的帮助！同时我也是通过论坛认真在学习！

lrh788

一把小刀闯天下 发表于 2018-6-7 15:51
'变得复杂很多，也毫无意义
'没有排序功能。19楼中已作说明，你自己的帖子你都不知道？
'觉得你是在玩 ...

老师，我刚才测试了你的代码，没有达到要求，重复数据查找有遗漏，其中一列为空仍然没有查到重复。另外，我自己写了一个填充序列号的代码，老师你看下是否不能优化？

Sub 填充序列号()
Dim i&, n&
For i = 2 To [A1048576].End(3).Row
    If Cells(i, 1) <> "" Or Cells(i, 1) = "" And Cells(i, 2) <> "" Then
        n = n + 1
        Cells(i, 5) = n
        End If
Next
End Sub

一把小刀闯天下

lrh788 发表于 2018-6-7 19:37
老师，我刚才测试了你的代码，没有达到要求，重复数据查找有遗漏，其中一列为空仍然没有查到重复

我当时随机测试了一下没发现毛病，可以把附件传上来看看，可以模拟数据只要能出问题就行。

lrh788

一把小刀闯天下 发表于 2018-6-7 20:42
我当时随机测试了一下没发现毛病，可以把附件传上来看看，可以模拟数据只要能出问题就行。

老师，你看下附件

一把小刀闯天下

lrh788 发表于 2018-6-7 21:10
老师，你看下附件

'用26楼的代码就可以了，需要对A、B、C列先排序（升序）。这是我在这个帖子中说了好几次了，这代码适合排序后的数据组（选中ABC列排序、升序，可以用代码排序但觉得没有什么意思）。另外第一列最后一行为空给你加了一行做判断：

Option Explicit

Sub test()
  Dim i As Long, j As Long, k As Long, n As Long, arr, dt
  Application.ScreenUpdating = False
  dt = Timer
  arr = [a1].CurrentRegion '因为A列数据列最后行缺了一个
  arr = Range("a3:c" & UBound(arr, 1) + 1)
  ReDim brr(1 To UBound(arr, 1), 1 To 1) As String
  For i = 1 To UBound(arr, 1) - 1
    For j = i To UBound(arr, 1) - 1
      If arr(j, 1) & arr(j, 2) & arr(j, 3) <> arr(j + 1, 1) & arr(j + 1, 2) & arr(j + 1, 3) Then
        If j > i Then
          n = 0
          For k = i To j
            brr(k, 1) = "重复" & n: n = n + 1
          Next
        Else
          brr(j, 1) = "唯一"
        End If
        i = j: Exit For
      End If
  Next j, i
  [d3].Resize(UBound(brr, 1)) = brr
  Debug.Print Timer - dt
  Application.ScreenUpdating = True
End Sub

lrh788

好的，谢谢老师，但是这里两个arr有点不好看，能否换成其他？？
arr = [a1].CurrentRegion '因为A列数据列最后行缺了一个  arr = Range("a3:c" & UBound(arr, 1) + 1)

一把小刀闯天下

lrh788 发表于 2018-6-7 22:01
好的，谢谢老师，但是这里两个arr有点不好看，能否换成其他？？
arr = [a1].CurrentRegion '因为A列数据列 ...

判断3列最大值，然后取最大值+1就可以了

lrh788

一把小刀闯天下 发表于 2018-6-7 22:22
判断3列最大值，然后取最大值+1就可以了

我觉得第一个arr换成其他变量名好看些？只是不知可否换成其他变量，如am。避免与第二个arr变量名混淆