[已解决]求个VBA

liuguansky

不知道你说的错，是哪里错了。 sd.rar (13.71 KB, 下载次数: 1)

2012-7-11 14:29 上传

点击文件名下载附件

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: T = True
    
37.     Next I
    
38.     [A:A].ClearContents
    
39.     [a1].Resize(K) = Ag
    
40.     Erase Ar
    
41. End Sub
    

复制代码

加一个
T＝TURE

fghji

liuguansky 发表于 2012-7-11 14:31
加一个
T＝TURE

这个附件很清楚错在哪里 sd.rar (12.93 KB, 下载次数: 1)

2012-7-11 15:45 上传

点击文件名下载附件

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), 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.不好意思。