[已解决]求个VBA

fghji

sd.rar (8.98 KB, 下载次数: 36)

2012-7-11 00:21 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

liuguansky

2012-7-11 16:03

1. Sub jusT()
   
2.     Dim Ar(1 To 3) As New Dictionary, A, B, T As Boolean, Lm As Byte, K&
   
3.     Dim Arr, I&, S$(1 To 3), j As Byte, Ln As Byte, Ag(1 To 10000, 1 To 1) As String
   
4.     Arr = Range([f4], [h4].End(4)).Value
   
5.     S(1) = [f4] & [f5] & [f6] & [f7]
   
6.     S(2) = [g4] & [g5] & [g6] & [g7]
   
7.     S(3) = [h4] & [h5] & [h6] & [h7]
   
8.     T = True
   
9.     For I = 5 To UBound(Arr)
   
10.         For j = 1 To 3
    
11.             If I = 5 Then
    
12.                 S(j) = S(j) & Arr(I, j)
    
13.             Else
    
14.                 S(j) = Mid(S(j), 1 + Len(Arr(I - 5, j))) & Arr(I, j)
    
15.             End If
    
16.             For Ln = 1 To Len(S(j))
    
17.                 Ar(j)(Mid(S(j), Ln, 1)) = Ar(j)(Mid(S(j), Ln, 1)) + 1
    
18.             Next Ln
    
19.             A = Ar(j).Keys: B = Ar(j).Items
    
20.             For Ln = 0 To UBound(A)
    
21.                 If B(Ln) > 1 Then
    
22.                     Ar(j).Remove A(Ln)
    
23.                 End If
    
24.             Next Ln
    
25.             T = T And (Ar(j).Count > 0)
    
26.         Next j
    
27.         If T Then
    
28.             For j = 1 To Ar(1).Count
    
29.                 For Ln = 1 To Ar(2).Count
    
30.                     For Lm = 1 To Ar(3).Count
    
31.                         If Ar(1).Keys(j - 1) <> "0" Then
    
32.                             K = K + 1: Ag(K, 1) = Ar(1).Keys(j - 1) & Ar(2).Keys(Ln - 1) & Ar(3).Keys(Lm - 1)
    
33.                         End If
    
34.             Next Lm, Ln, j
    
35.         End If
    
36.         Erase Ar: T = True
    
37.     Next I
    
38.     [A:A].ClearContents
    
39.     [a1].Resize(K) = Ag
    
40.     Erase Ar
    
41. End Sub
    

复制代码

错开了一位，14行加一个1.不好意思。

跳转到最佳答案楼层

wangzan

看不明白，要是没有重复小于2又怎么办？

fghji

wangzan 发表于 2012-7-11 07:24
看不明白，要是没有重复小于2又怎么办？

没有就不用组合呀.

liuguansky

1. Sub jusT()
   
2.     Dim Ar(1 To 3) As New Dictionary, A, B, T As Boolean, Lm As Byte, K&
   
3.     Dim Arr, I&, S$(1 To 3), j As Byte, Ln As Byte, Ag(1 To 10000, 1 To 1) As String
   
4.     Arr = Range([f4], [h4].End(4)).Value
   
5.     S(1) = [f4] & [f5] & [f6] & [f7]
   
6.     S(2) = [g4] & [g5] & [g6] & [g7]
   
7.     S(3) = [h4] & [h5] & [h6] & [h7]
   
8.     T = True
   
9.     For I = 5 To UBound(Arr)
   
10.         For j = 1 To 3
    
11.             If I = 5 Then
    
12.                 S(j) = S(j) & Arr(I, j)
    
13.             Else
    
14.                 S(j) = Mid(S(j), Len(Arr(I - 5, j))) & Arr(I, j)
    
15.             End If
    
16.             For Ln = 1 To Len(S(j))
    
17.                 Ar(j)(Mid(S(j), Ln, 1)) = Ar(j)(Mid(S(j), Ln, 1)) + 1
    
18.             Next Ln
    
19.             A = Ar(j).Keys: B = Ar(j).Items
    
20.             For Ln = 0 To UBound(A)
    
21.                 If B(Ln) > 1 Then
    
22.                     Ar(j).Remove A(Ln)
    
23.                 End If
    
24.             Next Ln
    
25.             T = T And (Ar(j).Count > 0)
    
26.         Next j
    
27.         If T Then
    
28.             For j = 1 To Ar(1).Count
    
29.                 For Ln = 1 To Ar(2).Count
    
30.                     For Lm = 1 To Ar(3).Count
    
31.                         If Ar(1).Keys(j - 1) <> "0" Then
    
32.                             K = K + 1: Ag(K, 1) = Ar(1).Keys(j - 1) & Ar(2).Keys(Ln - 1) & Ar(3).Keys(Lm - 1)
    
33.                         End If
    
34.             Next Lm, Ln, j
    
35.         End If
    
36.     Next I
    
37.     [A:A].ClearContents
    
38.     [a1].Resize(K) = Ag
    
39.     Erase Ar
    
40. End Sub

复制代码

看下是附件效果不？

liuguansky

{:031:}附件好难上传 sd.rar (13.19 KB, 下载次数: 13)

2012-7-11 09:12 上传

点击文件名下载附件

fghji

liuguansky 发表于 2012-7-11 09:13
附件好难上传

只是4到8行的结果正确,5到9行,6到10行等到15行的结果错

liuguansky

35行后加一句
erase ar
试试

fghji

liuguansky 发表于 2012-7-11 09:45
35行后加一句
erase ar
试试

11到15行还是错的

fghji

liuguansky 发表于 2012-7-11 09:45
35行后加一句
erase ar
试试

前面都是对的,后面怎么是错得呢,

liuguansky

1. Sub jusT()
   
2.     Dim Ar(1 To 3) As New Dictionary, A, B, T As Boolean, Lm As Byte, K&
   
3.     Dim Arr, I&, S$(1 To 3), j As Byte, Ln As Byte, Ag(1 To 10000, 1 To 1) As String
   
4.     Arr = Range([f4], [h4].End(4)).Value
   
5.     S(1) = [f4] & [f5] & [f6] & [f7]
   
6.     S(2) = [g4] & [g5] & [g6] & [g7]
   
7.     S(3) = [h4] & [h5] & [h6] & [h7]
   
8.     T = True
   
9.     For I = 5 To UBound(Arr)
   
10.         For j = 1 To 3
    
11.             If I = 5 Then
    
12.                 S(j) = S(j) & Arr(I, j)
    
13.             Else
    
14.                 S(j) = Mid(S(j), Len(Arr(I - 5, j))) & Arr(I, j)
    
15.             End If
    
16.             For Ln = 1 To Len(S(j))
    
17.                 Ar(j)(Mid(S(j), Ln, 1)) = Ar(j)(Mid(S(j), Ln, 1)) + 1
    
18.             Next Ln
    
19.             A = Ar(j).Keys: B = Ar(j).Items
    
20.             For Ln = 0 To UBound(A)
    
21.                 If B(Ln) > 1 Then
    
22.                     Ar(j).Remove A(Ln)
    
23.                 End If
    
24.             Next Ln
    
25.             T = T And (Ar(j).Count > 0)
    
26.         Next j
    
27.         If T Then
    
28.             For j = 1 To Ar(1).Count
    
29.                 For Ln = 1 To Ar(2).Count
    
30.                     For Lm = 1 To Ar(3).Count
    
31.                         If Ar(1).Keys(j - 1) <> "0" Then
    
32.                             K = K + 1: Ag(K, 1) = Ar(1).Keys(j - 1) & Ar(2).Keys(Ln - 1) & Ar(3).Keys(Lm - 1)
    
33.                         End If
    
34.             Next Lm, Ln, j
    
35.         End If
    
36.         Erase Ar
    
37.     Next I
    
38.     [A:A].ClearContents
    
39.     [a1].Resize(K) = Ag
    
40.     Erase Ar
    
41. End Sub
    

复制代码