检查序号是否连续并指出重复或遗漏的序号.xlsm

AFree123

如题

序号原本是连续的，但是由于数据调整过程，出现了问题

为便于其他的核对，不能重新编辑序号

查找A列序号是否连续，遗漏了哪些序号

检查A列序号是否重复，重复了哪些序号

如果不连续，遗漏的序号，在表2的A列标出

如果重复，重复的序号，在表2的B列标出

请问

使用VBA可以达到表2的效果吗？

感谢大侠的帮助！

谢谢！

一把小刀闯天下

Option Explicit

Sub test()
  Dim i, a, b, arr
  arr = Sheets("sheet1").[a1].CurrentRegion
  ReDim brr(arr(3, 1) To arr(UBound(arr, 1), 1))
  For i = 3 To UBound(arr, 1)
    brr(arr(i, 1)) = brr(arr(i, 1)) + 1
  Next
  ReDim arr(1 To UBound(arr, 1), 1 To 2)
  For i = LBound(brr) To UBound(brr)
    If Len(brr(i)) = 0 Then
      a = a + 1: arr(a, 1) = i
    ElseIf brr(i) > 1 Then
      b = b + 1: arr(b, 2) = i
    End If
  Next
  Sheets("sheet2").[a2].Resize(UBound(arr, 1), 2) = arr
End Sub

AFree123

老师，您好！谢谢您的帮助！针对本例，您的代码OK

但是如果序号为1、2、3、5、6、8、8、10、11、13、18、19、20、22、22、23、24、25、38
最后一个超过39（将38改39）就会提示下标越界
如果序号为1、2、3、5、6、8、8、10、11、13、18、19、20、22、22、23、24、25、38、41
最后一个超过42就会提示下标越界
如果序号为1、2、3、5、6、8、8、10、11、13、18、19、20、22、22、23、24、25、38、40、41、43、44、45、46、51
最后一个超过53就会提示下标越界
这是为什么？该怎么修改？

chaohuahch

下面的代码，供测试：

iwangyi

经典解答，学习了

一把小刀闯天下

AFree123 发表于 2018-7-28 11:24
老师，您好！谢谢您的帮助！针对本例，您的代码OK

但是如果序号为1、2、3、5、6、8、8、10、11、13、18 ...

'修改了一下，支持无序。其实我没看懂你在说什么，因为你的例子都不会出错

'如果再有问题就上附件

Option Explicit

Sub test()
  Dim i, a, b, arr, min, max
  arr = Sheets("sheet1").[a1].CurrentRegion
  min = 10 ^ 8: max = 0
  For i = 3 To UBound(arr, 1)
    If min > arr(i, 1) Then min = arr(i, 1)
    If max < arr(i, 1) Then max = arr(i, 1)
  Next
  ReDim brr(min To max)
  For i = 3 To UBound(arr, 1)
    brr(arr(i, 1)) = brr(arr(i, 1)) + 1
  Next
  ReDim arr(1 To UBound(arr, 1), 1 To 2)
  For i = LBound(brr) To UBound(brr)
    If Len(brr(i)) = 0 Then
      a = a + 1: arr(a, 1) = i
    ElseIf brr(i) > 1 Then
      b = b + 1: arr(b, 2) = i
    End If
  Next
  Sheets("sheet2").[a2].Resize(UBound(arr, 1), 2) = arr
End Sub

AFree123

一把小刀闯天下 发表于 2018-7-28 12:14
'修改了一下，支持无序。其实我没看懂你在说什么，因为你的例子都不会出错

'如果再有问题就上附件

谢谢老师的帮助
由于我表述不清楚，让您费解了。对不起
有关测试问题如附件，麻烦老师再看看，谢谢

AFree123

chaohuahch 发表于 2018-7-28 11:28
下面的代码，供测试：

老师好！谢谢您的帮助
我试了一下，提示，下标越界
可否帮我在看看问题出在哪里？

一把小刀闯天下

AFree123 发表于 2018-7-28 17:18
老师好！谢谢您的帮助
我试了一下，提示，下标越界
可否帮我在看看问题出在哪里？

'因为遗漏的数比现有的数还多，没考虑这问题可能

'现在遗漏100万个数也没有问题了,自己再测试一下

Option Explicit

Sub test()
  Dim i, a, b, arr, min, max
  With Sheets("sheet1")
    arr = .Range("a3:b" & .Cells(Rows.Count, "a").End(xlUp).Row)
  End With
  min = 10 ^ 8: max = 0
  For i = 1 To UBound(arr, 1)
    If min > arr(i, 1) Then min = arr(i, 1)
    If max < arr(i, 1) Then max = arr(i, 1)
  Next
  ReDim brr(min To max)
  For i = 1 To UBound(arr, 1)
    brr(arr(i, 1)) = brr(arr(i, 1)) + 1
  Next
  ReDim arr(1 To Rows.Count, 1 To 2)
  max = 0
  For i = LBound(brr) To UBound(brr)
    If Len(brr(i)) = 0 Then
      a = a + 1: arr(a, 1) = i
      If max < a Then max = a
    ElseIf brr(i) > 1 Then
      b = b + 1: arr(b, 2) = i
      If max < b Then max = b
    End If
  Next
  With Sheets("sheet2").[a1]
    .Resize(Rows.Count, 2).ClearContents
    .Resize(, 2) = Split("遗漏序号 重复序号")
    If max > 0 Then .Offset(1).Resize(max, 2) = arr
  End With
End Sub

AFree123

一把小刀闯天下 发表于 2018-7-28 17:24
'因为遗漏的数比现有的数还多，没考虑这问题可能

'现在遗漏100万个数也没有问题了,自己再测试一下

真是神人，又快又好，谢谢！