[已解决]复杂的计算统计问题

mate33

复杂的计算统计问题

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-4-20 20:45

1. Sub aaa()
   
2. Dim i&, s$, s1$, j&, rng As Range, d As Object, n&, brr(1 To 1000, 1 To 6), r1&, r2, c
   
3. Set d = CreateObject("scripting.dictionary")
   
4. For Each rng In Selection
   
5.   If rng.Interior.Color = vbRed Then d(rng.Offset(1).Value) = ""
   
6. Next rng
   
7. For i = 0 To 999
   
8.   s = Format(i, "000")
   
9.   s1 = Join(d.keys, "")
   
10.   For j = 1 To 3
    
11.     If InStr(s1, Mid(s, j, 1)) Then n = n + 1
    
12.     If n = 2 Then Exit For
    
13.   Next j
    
14.   If n = 2 Then
    
15.     r = r + 1
    
16.     For j = 1 To 3
    
17.       brr(r, j) = Mid(s, j, 1)
    
18.     Next j
    
19.   Else
    
20.     r1 = r1 + 1
    
21.     For j = 4 To 6
    
22.       brr(r1, j) = Mid(s, j - 3, 1)
    
23.     Next j
    
24.   End If
    
25.   n = 0
    
26. Next i
    
27. [k30] = d.Count
    
28. [k32].Resize(d.Count) = Application.Transpose(d.keys)
    
29. [n30].Resize(1000, 6) = brr
    
30. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

你的模拟结果错了，不重复的应该是73965，324是没有的，要取下一行。
代码请测试，注意根据你的说明，只能选择单行，多行时也能运行，但结果是不是你要的就不知道了。

1. Sub aaa()
   
2. Dim i&, s$, s1$, j&, rng As Range, d As Object, n&, brr(1 To 1000, 1 To 6), r1&, r2, c
   
3. Set d = CreateObject("scripting.dictionary")
   
4. For Each rng In Selection
   
5.   If rng.Interior.Color = vbRed Then d(rng.Offset(1).Value) = ""
   
6. Next rng
   
7. For i = 0 To 999
   
8.   s = Format(i, "000")
   
9.   s1 = Join(d.keys, "")
   
10.   For Each c In d.keys
    
11.     If InStr(s, c) Then n = n + 1
    
12.     If n = 2 Then Exit For
    
13.   Next c
    
14.   If n = 2 Then
    
15.     r = r + 1
    
16.     For j = 1 To 3
    
17.       brr(r, j) = Mid(s, j, 1)
    
18.     Next j
    
19.   Else
    
20.     r1 = r1 + 1
    
21.     For j = 4 To 6
    
22.       brr(r1, j) = Mid(s, j - 3, 1)
    
23.     Next j
    
24.   End If
    
25.   n = 0
    
26. Next i
    
27. MsgBox s1
    
28. [k30] = d.Count
    
29. [n30].Resize(1000, 6) = brr
    
30. End Sub

复制代码

大灰狼1976

忘记删除调试内容了。

1. Sub aaa()
   
2. Dim i&, s$, j&, rng As Range, d As Object, n&, brr(1 To 1000, 1 To 6), r1&, r2, c
   
3. Set d = CreateObject("scripting.dictionary")
   
4. For Each rng In Selection
   
5.   If rng.Interior.Color = vbRed Then d(rng.Offset(1).Value) = ""
   
6. Next rng
   
7. For i = 0 To 999
   
8.   s = Format(i, "000")
   
9.   For Each c In d.keys
   
10.     If InStr(s, c) Then n = n + 1
    
11.     If n = 2 Then Exit For
    
12.   Next c
    
13.   If n = 2 Then
    
14.     r = r + 1
    
15.     For j = 1 To 3
    
16.       brr(r, j) = Mid(s, j, 1)
    
17.     Next j
    
18.   Else
    
19.     r1 = r1 + 1
    
20.     For j = 4 To 6
    
21.       brr(r1, j) = Mid(s, j - 3, 1)
    
22.     Next j
    
23.   End If
    
24.   n = 0
    
25. Next i
    
26. [k30] = d.Count
    
27. [n30].Resize(1000, 6) = brr
    
28. End Sub

复制代码

mate33

大灰狼1976 发表于 2017-4-20 10:37
忘记删除调试内容了。

谢谢！非常抱歉，后面排列的表述错误，麻烦修改下代码。

大灰狼1976

1. Sub aaa()
   
2. Dim i&, s$, s1$, j&, rng As Range, d As Object, n&, brr(1 To 1000, 1 To 6), r1&, r2, c
   
3. Set d = CreateObject("scripting.dictionary")
   
4. For Each rng In Selection
   
5.   If rng.Interior.Color = vbRed Then d(rng.Offset(1).Value) = ""
   
6. Next rng
   
7. For i = 0 To 999
   
8.   s = Format(i, "000")
   
9.   s1 = Join(d.keys, "")
   
10.   For j = 1 To 3
    
11.     If InStr(s1, Mid(s, j, 1)) Then n = n + 1
    
12.     If n = 2 Then Exit For
    
13.   Next j
    
14.   If n = 2 Then
    
15.     r = r + 1
    
16.     For j = 1 To 3
    
17.       brr(r, j) = Mid(s, j, 1)
    
18.     Next j
    
19.   Else
    
20.     r1 = r1 + 1
    
21.     For j = 4 To 6
    
22.       brr(r1, j) = Mid(s, j - 3, 1)
    
23.     Next j
    
24.   End If
    
25.   n = 0
    
26. Next i
    
27. [k30] = d.Count
    
28. [k32].Resize(d.Count) = Application.Transpose(d.keys)
    
29. [n30].Resize(1000, 6) = brr
    
30. End Sub

复制代码