[已解决]数字排列去重

excel6006

求高手求出需要的结果

最佳答案

月排行榜 / 总排行榜

suye1010

2013-11-2 19:41

1. Sub ExtractData()
   
2. Dim arr, arr1, arr2, arr3, arr4(), TempArr(1 To 2), i, m, d, r, s, t, dc, z
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. arr = Range("AE1:AG" & Range("AE65536").End(xlUp).Row)
   
5. m = 1
   
6. For i = 1 To UBound(arr)
   
7. arr1 = Split(arr(i, 1), ",")
   
8. arr2 = Split(arr(i, 2), ",")
   
9. arr3 = Split(arr(i, 3), ",")
   
10. For r = 0 To UBound(arr1)
    
11. For s = 0 To UBound(arr2)
    
12. For t = 0 To UBound(arr3)
    
13. If d.Exists(arr1(r) & arr2(s) & arr3(t)) Then
    
14. If d(arr1(r) & arr2(s) & arr3(t))(1) <> m Then
    
15. TempArr(1) = m
    
16. TempArr(2) = d(arr1(r) & arr2(s) & arr3(t))(2) + 1
    
17. d(arr1(r) & arr2(s) & arr3(t)) = TempArr
    
18. End If
    
19. Else
    
20. TempArr(1) = m
    
21. TempArr(2) = 1
    
22. d(arr1(r) & arr2(s) & arr3(t)) = TempArr
    
23. End If
    
24. Next t
    
25. Next s
    
26. Next r
    
27. If i < UBound(arr) Then
    
28. If arr(i + 1, 1) = "" Then
    
29. i = i + 1
    
30. m = m + 1
    
31. GoTo 100
    
32. End If
    
33. End If
    
34. 100:
    
35. Next i
    
36. For Each dc In d.keys
    
37. If d(dc)(2) = m Then
    
38. z = z + 1
    
39. ReDim Preserve arr4(1 To z)
    
40. arr4(z) = dc
    
41. End If
    
42. Next
    
43. Columns("AL").NumberFormatLocal = "@"
    
44. If z = 0 Then Exit Sub
    
45. If Range("AL1") = "" Then
    
46. Range("AL1").Resize(z) = Application.Transpose(arr4)
    
47. Else
    
48. Range("AL" & Range("AL65536").End(xlUp).Row + 1).Resize(z) = Application.Transpose(arr4)
    
49. End If
    
50. End Sub
    

复制代码

跳转到最佳答案楼层

suye1010

1. Sub ExtractData()
   
2. Dim arr, arr1, arr2, arr3, arr4(), TempArr(1 To 2), i, m, d, r, s, t, dc, z
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. arr = Range("AE1:AG" & Range("AE65536").End(xlUp).Row)
   
5. m = 1
   
6. For i = 1 To UBound(arr)
   
7. arr1 = Split(arr(i, 1), ",")
   
8. arr2 = Split(arr(i, 2), ",")
   
9. arr3 = Split(arr(i, 3), ",")
   
10. For r = 0 To UBound(arr1)
    
11. For s = 0 To UBound(arr2)
    
12. For t = 0 To UBound(arr3)
    
13. If d.Exists(arr1(r) & arr2(s) & arr3(t)) Then
    
14. If d(arr1(r) & arr2(s) & arr3(t))(1) <> m Then
    
15. TempArr(1) = m
    
16. TempArr(2) = d(arr1(r) & arr2(s) & arr3(t))(2) + 1
    
17. d(arr1(r) & arr2(s) & arr3(t)) = TempArr
    
18. End If
    
19. Else
    
20. TempArr(1) = m
    
21. TempArr(2) = 1
    
22. d(arr1(r) & arr2(s) & arr3(t)) = TempArr
    
23. End If
    
24. Next t
    
25. Next s
    
26. Next r
    
27. If i < UBound(arr) Then
    
28. If arr(i + 1, 1) = "" Then
    
29. i = i + 1
    
30. m = m + 1
    
31. GoTo 100
    
32. End If
    
33. End If
    
34. 100:
    
35. Next i
    
36. For Each dc In d.keys
    
37. If d(dc)(2) = m Then
    
38. z = z + 1
    
39. ReDim Preserve arr4(1 To z)
    
40. arr4(z) = dc
    
41. End If
    
42. Next
    
43. Columns("AL").NumberFormatLocal = "@"
    
44. If z = 0 Then Exit Sub
    
45. If Range("AL1") = "" Then
    
46. Range("AL1").Resize(z) = Application.Transpose(arr4)
    
47. Else
    
48. Range("AL" & Range("AL65536").End(xlUp).Row + 1).Resize(z) = Application.Transpose(arr4)
    
49. End If
    
50. End Sub
    

复制代码