[已解决]求助老师个多列去重提出两数的代码

dfzc

如题，附件里有详细说明，请老师帮助解决个代码，谢谢！
Book1.zip (14.36 KB, 下载次数: 11)

2014-6-2 12:24 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

sliang28

2014-6-2 15:08

不好意思，这个条件给忘记了，代码修改如下：

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, brr, crr
   
3.     Dim iRow As Integer, i As Integer, j As Integer, k As Integer
   
4.     Dim d As Object
   
5.     Dim cobQty As Integer
   
6.     Dim myStr As String, myStr1 As String
   
7.     t = Timer
   
8.     cobQty = Val(ComboBox1.Text)
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     iRow = Range("B65536").End(3).Row
    
11.     arr = Range("B4:F" & iRow)
    
12.     ReDim brr(1 To UBound(arr), 1 To 6) As String
    
13.     crr = myArray()
    
14.     For i = 1 To 6
    
15.         For j = UBound(arr) To 1 Step -1
    
16.             For k = j To 1 Step -1
    
17.                 myStr = arr(k, crr(i)(0)) & arr(k, crr(i)(1))
    
18.                 myStr1 = arr(k, crr(i)(1)) & arr(k, crr(i)(0))
    
19.                 If Not d.exists(myStr1) Then d(myStr) = ""
    
20.                 If d.Count = cobQty Then Exit For
    
21.             Next
    
22.             brr(j, i) = Join(d.keys, " ")
    
23.             d.RemoveAll
    
24.         Next
    
25.         Cells(4, 16 + (i - 1) * 13).Resize(UBound(brr)).ClearContents
    
26.         Cells(4, 16 + (i - 1) * 13).Resize(UBound(brr)) = Application.Index(brr, , i)
    
27.     Next
    
28.     MsgBox "提取结束，用时：" & Format(Timer - t, "0.0000") & "秒"
    
29. End Sub
    
30. Function myArray() As Variant
    
31.     Dim cr(1 To 6)
    
32.     Dim ar1(1), ar2(1), ar3(1), ar4(1), ar5(1), ar6(1)
    
33.     ar1(0) = 1: ar1(1) = 2
    
34.     ar2(0) = 1: ar2(1) = 3
    
35.     ar3(0) = 2: ar3(1) = 3
    
36.     ar4(0) = 3: ar4(1) = 4
    
37.     ar5(0) = 3: ar5(1) = 5
    
38.     ar6(0) = 4: ar6(1) = 5
    
39.     cr(1) = ar1
    
40.     cr(2) = ar2
    
41.     cr(3) = ar3
    
42.     cr(4) = ar4
    
43.     cr(5) = ar5
    
44.     cr(6) = ar6
    
45.     myArray = cr
    
46. End Function

复制代码

跳转到最佳答案楼层

大灰狼1976

“万千、万百、千百、百十、百个、十个”没有规律，太麻烦了，我做了个“万千，千百，百十，十个”的，
你先看看，原理是一样的，不过列不好循环，没耐性做了。
附件请测试。
注：可以用combobox1的选定值来确定所需要生成的个数。

1. Private Sub CommandButton1_Click()
   
2. Dim arr, brr, i&, j&, k&, n&, d As Object
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("b4:f" & [b65536].End(3).Row)
   
5. ReDim brr(1 To UBound(arr), 1 To 4)
   
6. n = ComboBox1
   
7. For j = 1 To UBound(arr, 2) - 1
   
8.   For i = UBound(arr) To 1 Step -1
   
9.     For k = i To 1 Step -1
   
10.       d(Application.Min(arr(k, j), arr(k, j + 1)) & Application.Max(arr(k, j), arr(k, j + 1))) = ""
    
11.       If d.Count = n Then Exit For
    
12.     Next k
    
13.     brr(i, j) = Join(d.keys)
    
14.     d.RemoveAll
    
15.   Next i
    
16. Next j
    
17. For j = 1 To 4
    
18.   Cells(4, 16 + (j - 1) * 13).Resize(UBound(brr)) = Application.Index(brr, , j)
    
19. Next j
    
20. End Sub

复制代码

大灰狼1976

修改了下代码，速度是原来的5倍。

1. Private Sub CommandButton1_Click()
   
2. Dim arr, brr, i&, j&, k&, n&, s$, d As Object
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("b4:f" & [b65536].End(3).Row)
   
5. ReDim brr(1 To UBound(arr), 1 To 4)
   
6. n = ComboBox1
   
7. For j = 1 To UBound(arr, 2) - 1
   
8.   For i = UBound(arr) To 1 Step -1
   
9.     For k = i To 1 Step -1
   
10.     If arr(k, j) > arr(k, j + 1) Then s = arr(k, j + 1) & arr(k, j) Else s = arr(k, j) & arr(k, j + 1)
    
11.       d(s) = ""
    
12.       If d.Count = n Then Exit For
    
13.     Next k
    
14.     brr(i, j) = Join(d.keys)
    
15.     d.RemoveAll
    
16.   Next i
    
17. Next j
    
18. For j = 1 To 4
    
19.   Cells(4, 16 + (j - 1) * 13).Resize(UBound(brr)) = Application.Index(brr, , j)
    
20. Next j
    
21. End Sub

复制代码

dfzc

非常感谢大灰狼1976 ，代码测试过了，确实是去重和按ComboBox1提取了个数，但是提取的两数没有按位置正确显示，如十个中的42，显示成了24，97显示成了79，还望老师们能给个正确的及按要求提取的代码，辛苦了谢谢

sliang28

请参考！

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, brr, crr
   
3.     Dim iRow As Integer, i As Integer, j As Integer, k As Integer
   
4.     Dim d As Object
   
5.     Dim cobQty As Integer
   
6.     t = Timer
   
7.     cobQty = Val(ComboBox1.Text)
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     iRow = Range("B65536").End(3).Row
   
10.     arr = Range("B4:F" & iRow)
    
11.     ReDim brr(1 To UBound(arr), 1 To 6) As String
    
12.     crr = myArray()
    
13.     For i = 1 To 6
    
14.         For j = UBound(arr) To 1 Step -1
    
15.             For k = j To 1 Step -1
    
16.                 myStr = arr(k, crr(i)(0)) & arr(k, crr(i)(1))
    
17.                 d(myStr) = ""
    
18.                 If d.Count = cobQty Then Exit For
    
19.             Next
    
20.             brr(j, i) = Join(d.keys, " ")
    
21.             d.RemoveAll
    
22.         Next
    
23.         Cells(4, 16 + (i - 1) * 13).Resize(UBound(brr)).ClearContents
    
24.         Cells(4, 16 + (i - 1) * 13).Resize(UBound(brr)) = Application.Index(brr, , i)
    
25.     Next
    
26.     MsgBox "提取结束，用时：" & Format(Timer - t, "0.0000") & "秒"
    
27. End Sub
    
28. Function myArray() As Variant
    
29.     Dim cr(1 To 6)
    
30.     Dim ar1(1), ar2(1), ar3(1), ar4(1), ar5(1), ar6(1)
    
31.     ar1(0) = 1: ar1(1) = 2
    
32.     ar2(0) = 1: ar2(1) = 3
    
33.     ar3(0) = 2: ar3(1) = 3
    
34.     ar4(0) = 3: ar4(1) = 4
    
35.     ar5(0) = 3: ar5(1) = 5
    
36.     ar6(0) = 4: ar6(1) = 5
    
37.     cr(1) = ar1
    
38.     cr(2) = ar2
    
39.     cr(3) = ar3
    
40.     cr(4) = ar4
    
41.     cr(5) = ar5
    
42.     cr(6) = ar6
    
43.     myArray = cr
    
44. End Function

复制代码

dfzc

sliang28 老师代码测试过了，非常快，只是里面的还有重码，如54和45这种情况如果是有两数相同应也算是重码，辛苦再修改下去掉相同两数而不同位的重复码，就完善了，谢谢，期待修改.............

sliang28

不好意思，这个条件给忘记了，代码修改如下：

1. Private Sub CommandButton1_Click()
   
2.     Dim arr, brr, crr
   
3.     Dim iRow As Integer, i As Integer, j As Integer, k As Integer
   
4.     Dim d As Object
   
5.     Dim cobQty As Integer
   
6.     Dim myStr As String, myStr1 As String
   
7.     t = Timer
   
8.     cobQty = Val(ComboBox1.Text)
   
9.     Set d = CreateObject("scripting.dictionary")
   
10.     iRow = Range("B65536").End(3).Row
    
11.     arr = Range("B4:F" & iRow)
    
12.     ReDim brr(1 To UBound(arr), 1 To 6) As String
    
13.     crr = myArray()
    
14.     For i = 1 To 6
    
15.         For j = UBound(arr) To 1 Step -1
    
16.             For k = j To 1 Step -1
    
17.                 myStr = arr(k, crr(i)(0)) & arr(k, crr(i)(1))
    
18.                 myStr1 = arr(k, crr(i)(1)) & arr(k, crr(i)(0))
    
19.                 If Not d.exists(myStr1) Then d(myStr) = ""
    
20.                 If d.Count = cobQty Then Exit For
    
21.             Next
    
22.             brr(j, i) = Join(d.keys, " ")
    
23.             d.RemoveAll
    
24.         Next
    
25.         Cells(4, 16 + (i - 1) * 13).Resize(UBound(brr)).ClearContents
    
26.         Cells(4, 16 + (i - 1) * 13).Resize(UBound(brr)) = Application.Index(brr, , i)
    
27.     Next
    
28.     MsgBox "提取结束，用时：" & Format(Timer - t, "0.0000") & "秒"
    
29. End Sub
    
30. Function myArray() As Variant
    
31.     Dim cr(1 To 6)
    
32.     Dim ar1(1), ar2(1), ar3(1), ar4(1), ar5(1), ar6(1)
    
33.     ar1(0) = 1: ar1(1) = 2
    
34.     ar2(0) = 1: ar2(1) = 3
    
35.     ar3(0) = 2: ar3(1) = 3
    
36.     ar4(0) = 3: ar4(1) = 4
    
37.     ar5(0) = 3: ar5(1) = 5
    
38.     ar6(0) = 4: ar6(1) = 5
    
39.     cr(1) = ar1
    
40.     cr(2) = ar2
    
41.     cr(3) = ar3
    
42.     cr(4) = ar4
    
43.     cr(5) = ar5
    
44.     cr(6) = ar6
    
45.     myArray = cr
    
46. End Function

复制代码

dfzc

非常感谢sliang28老师，测试很好了，谢谢