[已解决]统计数组的求助

xutan2015

如图所示：想解决以下两个问题

第一个问题：
上一组数字中的5个数字（5个数须互不相同），和下一组数字中的5个数字完全相同。那么在下一组的数字的下一列的同行单元格里显示“1”，否则不显示任何信息。请各位大侠帮忙

5个数字之间位置可以任意颠倒。但上下两组数字的5个数字本身必须相同。

第二个问题：
上一组数字中的5个数字中，有任意4个数字（4个数须互不相同，余下的1个数任意）和下一组数字中的任意4个数字完全相同。那么在下一组的数字的下一列的同行单元格里显示“1”，否则不显示任何信息。请各位大侠帮忙

附件有样表

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-19 13:10

问题一

1. Sub Macro1()
   
2. Dim arr, brr, w(9), i&, j%
   
3. arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
   
4. ReDim brr(1 To UBound(arr), 1 To 1)
   
5. For i = 1 To UBound(arr)
   
6.     s = arr(i, 1)
   
7.     For j = 1 To Len(s)
   
8.         n = Mid(s, j, 1)
   
9.         w(n) = n
   
10.     Next
    
11.     brr(i, 1) = Join(w, "")
    
12.     Erase w
    
13.     If i > 1 Then
    
14.         If brr(i, 1) = brr(i - 1, 1)  and len(brr(i,1))=5 Then Cells(i, 2) = 1
    
15.     End If
    
16. Next
    
17. End Sub

复制代码

跳转到最佳答案楼层

dsmch

问题一

1. Sub Macro1()
   
2. Dim arr, brr, w(9), i&, j%
   
3. arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
   
4. ReDim brr(1 To UBound(arr), 1 To 1)
   
5. For i = 1 To UBound(arr)
   
6.     s = arr(i, 1)
   
7.     For j = 1 To Len(s)
   
8.         n = Mid(s, j, 1)
   
9.         w(n) = n
   
10.     Next
    
11.     brr(i, 1) = Join(w, "")
    
12.     Erase w
    
13.     If i > 1 Then
    
14.         If brr(i, 1) = brr(i - 1, 1)  and len(brr(i,1))=5 Then Cells(i, 2) = 1
    
15.     End If
    
16. Next
    
17. End Sub

复制代码

蓝桥玄霜

1. Sub lqxs()
   
2. Dim Arr, i&, j&, y&, a$, d
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. Sheet1.Activate
   
5. [b:b].ClearContents
   
6. Arr = [a1].CurrentRegion
   
7. For i = 1 To UBound(Arr) - 1
   
8.     For y = 1 To Len(Arr(i, 1))
   
9.         a = Mid(Arr(i, 1), y, 1)
   
10.         If d.exists(a) Then
    
11.             GoTo 100
    
12.         Else
    
13.             d(a) = ""
    
14.         End If
    
15.     Next
    
16.     k = d.keys
    
17.     For j = i + 1 To UBound(Arr)
    
18.         For y = 0 To UBound(k)
    
19.             If InStr(Arr(j, 1), k(y)) = 0 Then GoTo 100
    
20.         Next
    
21.         Cells(j, 2) = 1
    
22.     Next
    
23. 100:
    
24. d.RemoveAll
    
25. Next
    
26. End Sub
    
27. Sub lqxs2()
    
28. Dim Arr, i&, j&, y&, a$, d, n&
    
29. Set d = CreateObject("Scripting.Dictionary")
    
30. Sheet2.Activate
    
31. [b:b].ClearContents
    
32. Arr = [a1].CurrentRegion
    
33. For i = 1 To UBound(Arr) - 1
    
34.     For y = 1 To Len(Arr(i, 1))
    
35.         a = Mid(Arr(i, 1), y, 1)
    
36.         d(a) = ""
    
37.     Next
    
38.     If d.Count < 4 Then GoTo 100
    
39.     k = d.keys
    
40.     For j = i + 1 To UBound(Arr)
    
41.         n = 0
    
42.         For y = 0 To UBound(k)
    
43.             If InStr(Arr(j, 1), k(y)) Then
    
44.                 n = n + 1
    
45.             End If
    
46.         Next
    
47.         If n = 4 Then Cells(j, 2) = 1
    
48.     Next
    
49. 100:
    
50. d.RemoveAll
    
51. Next
    
52. End Sub
    
53. 
    

复制代码

dsmch

问题二

1. Sub Macro2()
   
2. Dim arr, brr, w(9), i&, j%
   
3. arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
   
4. ReDim brr(1 To UBound(arr), 1 To 1)
   
5. s = arr(1, 1)
   
6. For j = 1 To Len(s)
   
7.     n = Mid(s, j, 1)
   
8.     w(n) = n
   
9. Next
   
10. brr(1, 1) = Join(w, "")
    
11. Erase w
    
12. For i = 2 To UBound(arr)
    
13.     s = arr(i, 1): s2 = 0
    
14.     For j = 1 To Len(s)
    
15.         n = Mid(s, j, 1)
    
16.         w(n) = n
    
17.         If InStr(brr(i - 1, 1), n) Then s2 = s2 + 1
    
18.     Next
    
19.     brr(i, 1) = Join(w, "")
    
20.     Erase w
    
21.     If s2 = 4 And Len(brr(i, 1)) = 5 And Len(brr(i - 1, 1)) = 5 Then Cells(i, 2) = 1
    
22. Next
    
23. End Sub

复制代码

上清宫主

凑热闹：
Sub test1()
Dim ar1(), ar2(0 To 9)
ar1 = Range("a1:a18").Value
s1$ = ""
For i = 1 To UBound(ar1)
    For i2% = 1 To Len(ar1(i, 1))
        tmp% = Val(Mid(ar1(i, 1), i2, 1))
        ar2(tmp) = tmp
    Next
    s2$ = Join(ar2, "")
    ar1(i, 1) = ""
    If Len(s2) = 5 And s1 = s2 Then ar1(i, 1) = 1
    s1 = s2
    Erase ar2
Next
[b1].Resize(i - 1) = ar1
End Sub
Sub test2()
Dim ar1(), ar2(), ar3(), ar4(0 To 9)
ar1 = Range("a1:a18").Value
ReDim ar2(0 To 9)
For i2% = 1 To Len(ar1(1, 1))
   tmp% = Val(Mid(ar1(1, 1), i2, 1))
   ar2(tmp) = tmp
Next
ar1(1, 1) = ""
For i = 2 To UBound(ar1)
    ar3 = ar2
    For i2% = 1 To Len(ar1(i, 1))
        tmp% = Val(Mid(ar1(i, 1), i2, 1))
        ar4(tmp) = tmp
        ar3(tmp) = tmp
    Next
    s2$ = Join(ar2, "")
    s3$ = Join(ar3, "")
    s4$ = Join(ar4, "")
    ar1(i, 1) = ""
    If Len(s2) = 5 And Len(s3) = 6 And Len(s4) = 5 Then ar1(i, 1) = 1
    ar2 = ar4
    Erase ar4
Next
[b1].Resize(i - 1) = ar1
End Sub

上清宫主

楼主要五个数字互不相同哟

grf1973

我也来凑个热闹，借用2楼的思路，问题一二可以用相同代码解决。

1. Sub tt()
   
2.     Dim arr, brr, i&, j%
   
3.     arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
   
4.     ReDim brr(1 To UBound(arr), 1 To 1)
   
5.     For i = 2 To UBound(arr)
   
6.         s = 0: x = iSort(arr(i, 1))
   
7.         For k = 1 To Len(x)
   
8.             If InStr(arr(i - 1, 1), Mid(x, k, 1)) > 0 Then s = s + 1
   
9.         Next
   
10.         If s = 5 Then Cells(i, 2) = 1        '如果改成s=4就是问题二的答案
    
11.     Next
    
12. End Sub
    
13. Function iSort(xstr)      '把数据去掉重复数字，并从小到大排序
    
14.     Dim w(9)
    
15.     For i = 1 To Len(xstr)
    
16.         n = Val(Mid(xstr, i, 1))
    
17.         w(n) = n
    
18.     Next
    
19.     iSort = Join(w, "")
    
20. End Function
    

复制代码

grf1973

当然，如果不是考虑与问题二兼容的话，问题一的代码更简单：

1. Sub tt()
   
2.     Dim arr, brr, i&, j%
   
3.     arr = Range("a1:a" & Range("a65536").End(xlUp).Row)
   
4.     For i = 2 To UBound(arr)
   
5.         x1 = iSort(arr(i, 1)): x2 = iSort(arr(i - 1, 1))
   
6.         If x1 = x2 And Len(x1) = 5 Then Cells(i, 2) = 1
   
7.     Next
   
8. End Sub

复制代码