[已解决]求加个循环

uuw5

book1.rar (10.59 KB, 下载次数: 10)

2013-5-6 20:43 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-5-6 22:53

1. Sub 条件()
   
2.     Dim ar, br, cr, dr(1 To 5000, 1 To 1)
   
3.     Dim i, j, L1, L2, L3, M, n, k, o
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     o = 4
   
7.     For k = 10 To 16 Step 3
   
8.         ar = Range("E" & k & ":J" & k + 2)
   
9.         ar = Range("e10:j12")
   
10.         For j = 1 To UBound(ar, 2)
    
11.             For L1 = 1 To Len(ar(1, j))
    
12.                 For L2 = 1 To Len(ar(2, j))
    
13.                     For L3 = 1 To Len(ar(3, j))
    
14.                         M = ""
    
15.                         M = Mid(ar(1, j), L1, 1) & Mid(ar(2, j), L2, 1) & Mid(ar(3, j), L3, 1)
    
16.                         d(M) = d(M) + 1
    
17.                     Next L3
    
18.                 Next L2
    
19.             Next L1
    
20.         Next j
    
21.         br = d.keys
    
22.         cr = d.Items
    
23.         n = 0
    
24.         For i = 0 To UBound(cr)
    
25.             If cr(i) > 2 Then
    
26.                 n = n + 1
    
27.                 dr(n, 1) = br(i)
    
28.             End If
    
29.         Next
    
30.         o = Cells(Rows.Count, 1).End(xlUp).Row + 1
    
31.         Range("A" & o).Resize(n, 1) = dr
    
32.         d.RemoveAll
    
33.     Next
    
34. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

1. Sub 条件()
   
2.     Dim ar, br, cr, dr(1 To 5000, 1 To 1)
   
3.     Dim i, j, L1, L2, L3, M, n, k, o
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     o = 4
   
7.     For k = 10 To 16 Step 3
   
8.         ar = Range("E" & k & ":J" & k + 2)
   
9.         ar = Range("e10:j12")
   
10.         For j = 1 To UBound(ar, 2)
    
11.             For L1 = 1 To Len(ar(1, j))
    
12.                 For L2 = 1 To Len(ar(2, j))
    
13.                     For L3 = 1 To Len(ar(3, j))
    
14.                         M = ""
    
15.                         M = Mid(ar(1, j), L1, 1) & Mid(ar(2, j), L2, 1) & Mid(ar(3, j), L3, 1)
    
16.                         d(M) = d(M) + 1
    
17.                     Next L3
    
18.                 Next L2
    
19.             Next L1
    
20.         Next j
    
21.         br = d.keys
    
22.         cr = d.Items
    
23.         n = 0
    
24.         For i = 0 To UBound(cr)
    
25.             If cr(i) > 2 Then
    
26.                 n = n + 1
    
27.                 dr(n, 1) = br(i)
    
28.             End If
    
29.         Next
    
30.         Range("A" & o).Resize(n, 1) = dr
    
31.         o = Cells(Rows.Count, 1).End(xlUp).Row + 1
    
32.         d.RemoveAll
    
33.     Next
    
34. End Sub

复制代码

uuw5

hwc2ycy 发表于 2013-5-6 21:38

输出的位置不要固定从第四格开始,改成a列有数据的下一格开始

hwc2ycy

1. Sub 条件()
   
2.     Dim ar, br, cr, dr(1 To 5000, 1 To 1)
   
3.     Dim i, j, L1, L2, L3, M, n, k, o
   
4.     Dim d As Object
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     o = 4
   
7.     For k = 10 To 16 Step 3
   
8.         ar = Range("E" & k & ":J" & k + 2)
   
9.         ar = Range("e10:j12")
   
10.         For j = 1 To UBound(ar, 2)
    
11.             For L1 = 1 To Len(ar(1, j))
    
12.                 For L2 = 1 To Len(ar(2, j))
    
13.                     For L3 = 1 To Len(ar(3, j))
    
14.                         M = ""
    
15.                         M = Mid(ar(1, j), L1, 1) & Mid(ar(2, j), L2, 1) & Mid(ar(3, j), L3, 1)
    
16.                         d(M) = d(M) + 1
    
17.                     Next L3
    
18.                 Next L2
    
19.             Next L1
    
20.         Next j
    
21.         br = d.keys
    
22.         cr = d.Items
    
23.         n = 0
    
24.         For i = 0 To UBound(cr)
    
25.             If cr(i) > 2 Then
    
26.                 n = n + 1
    
27.                 dr(n, 1) = br(i)
    
28.             End If
    
29.         Next
    
30.         o = Cells(Rows.Count, 1).End(xlUp).Row + 1
    
31.         Range("A" & o).Resize(n, 1) = dr
    
32.         d.RemoveAll
    
33.     Next
    
34. End Sub

复制代码