查找不同项

buciyuan

sheet2中有一列循环数据，现在需要查找到这组循环数据中 欠缺了的数据，自己编写了一个程序没有调试成功，请各位大神指点一二，谢谢！

6位数，最大数=6，全排列时有46656个，但sheet2中只有46628，还差28个全排列的数，现在想把这个28个数找出来

蓝桥玄霜

查找的例子：

ykcbf1100

感觉没完全明白楼主说的意思，猜一个吧。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.4.6
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set List = CreateObject("System.Collections.ArrayList")
   
5.     With Sheets("Sheet2")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         arr = .[a1].Resize(r, 1)
   
8.     End With
   
9.     For i = 1 To UBound(arr)
   
10.         S = arr(i, 1)
    
11.         d(S) = ""
    
12.         If Not List.Contains(S) Then List.Add S
    
13.     Next
    
14.     List.Sort
    
15.     brr = List.toArray
    
16.     ReDim zrr(1 To 1000000, 1 To 1)
    
17.     On Error Resume Next
    
18.     r1 = brr(LBound(brr))
    
19.     r2 = brr(UBound(brr))
    
20.     m = 0
    
21.     For i = r1 To r2 Step 1
    
22.         If Not d.exists(i) Then
    
23.             m = m + 1
    
24.             zrr(m, 1) = i
    
25.         End If
    
26.     Next
    
27.     With Sheets("Sheet1")
    
28.         .Columns(1) = ""
    
29.         .[a1].Resize(m, 1) = zrr
    
30.     End With
    
31.     Application.ScreenUpdating = True
    
32.     MsgBox "OK！"
    
33. End Sub
    
34. 
    

复制代码

limonet

filter+match+row的公式可以

buciyuan

6位数，最大数=6，全排列时有46656个，但sheet2中只有46628，还差28个全排列的数，现在想把这个28个数找出来

gwjkkkkk

你这个应该是笛卡尔组合。。。

gwjkkkkk

Option Explicit
Sub test2()
    Dim ar, cr, dr, er, dic As Object
    Dim i&, j&, r&, m&, n&
   
    ReDim cr(1 To 6, 1 To 6)

    For j = 1 To 6
        For i = 1 To 6
            cr(i, j) = i
        Next i
    Next j

    m = UBound(cr): n = UBound(cr, 2)
    ReDim dr(1 To n)
    ReDim er(1 To m ^ n)

    Call cartesianProductDG1(cr, dr, er) ', r)
    cr = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Value
    ReDim dr(1 To UBound(er), 0)
   
    Set dic = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(cr)
        dic(CStr(cr(i, 1))) = Empty
    Next i
    For i = 1 To UBound(er)
        If Not dic.exists(er(i)) Then
            r = r + 1
            dr(r, 0) = er(i)
        End If
    Next i
   
    Columns("E").Clear
    [E1].Resize(r) = dr
End Sub

Function cartesianProductDG1(ByVal ar, ByVal br, ByRef vResult, _
    Optional ByRef iGroup&, Optional ByVal n& = 1)
    Dim i&, j&

    For i = 1 To UBound(ar)
        br(n) = ar(i, n)
        If n = UBound(ar, 2) Then
            iGroup = iGroup + 1
            vResult(iGroup) = Join(br, "")
        Else
            cartesianProductDG1 ar, br, vResult, iGroup, n + 1
        End If
    Next
End Function

gwjkkkkk

请参考附件。。。

buciyuan

ykcbf1100 发表于 2024-4-6 10:35
参与一下。。。

谢谢提供帮助