[已解决]求助vba

haeng

组合提起.rar (23.95 KB, 下载次数: 7)

2013-2-6 18:24 上传

点击文件名下载附件
忘了一点, "四个125组数如果有重复次数大于2的就显示在B列",     不是125组数跟125组数全相同, 四个125组数是指共500组数

最佳答案

月排行榜 / 总排行榜

suye1010

2013-2-7 11:01

1. Sub ExtractData()
   
2. Dim d0, d, i As Long, j As Long, k As Long, l As Integer, m As Integer, n As Integer, arr, TempNo, TempArr, x, y
   
3. arr = Range("G2:IS4")
   
4. Set d0 = CreateObject("Scripting.Dictionary")
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. For j = 1 To UBound(arr, 2) - 3 Step 4
   
7.     For k = 0 To 3
   
8.         For l = 1 To 5
   
9.             For m = 1 To 5
   
10.                 For n = 1 To 5
    
11.                     TempNo = Mid(arr(1, j + k), l, 1) & Mid(arr(2, j + k), m, 1) & Mid(arr(3, j + k), n, 1)
    
12.                     d0(TempNo) = d0(TempNo) + 1
    
13.                     If d0(TempNo) > 1 Then d((j \ 4 + 1) & " " & TempNo) = d0(TempNo) '在满足条件的数据前添加数加不同组别标识
    
14.                 Next n
    
15.             Next m
    
16.         Next l
    
17.     Next k
    
18. d0.RemoveAll
    
19. Next j
    
20. ReDim TempArr(1 To d.Count, 1 To 2)
    
21. For Each x In Application.Transpose(d.keys)
    
22.     y = y + 1
    
23.     TempArr(y, 1) = Split(x)(0)
    
24.     TempArr(y, 2) = Split(x)(1)
    
25. Next
    
26. Columns("A:C").ClearContents
    
27. Range("A2").Resize(d.Count, 1) = Application.Index(TempArr, , 1) '组别
    
28. Range("B2").Resize(d.Count, 1) = Application.Index(TempArr, , 2) '数字组合
    
29. Range("C2").Resize(d.Count, 1) = Application.Transpose(d.items)  '出现次数
    
30. End Sub

复制代码

组合提取.zip (116.45 KB, 下载次数: 5)

2013-2-7 11:01 上传

点击文件名下载附件

跳转到最佳答案楼层

那么的帅

1. Sub 组合()
   
2.     Dim ar1, ar2(0 To 999), ar3()
   
3.     On Error Resume Next
   
4.     ar1 = [G2].CurrentRegion.Value
   
5.     k = 0
   
6.     ReDim ar3(1 To 10000, 1 To 1)
   
7.     For i = 1 To UBound(ar1, 2) - 3
   
8.         s = 0
   
9.         For i1% = 1 To 4
   
10.             
    
11.             For i2% = 1 To 5
    
12.                 For i3% = 1 To 5
    
13.                     For i4% = 1 To 5
    
14.                         s = s + 1
    
15.                         ar2(Mid(ar1(1, i + i1 - 1), i2, 1) & Mid(ar1(2, i + i1 - 1), i3, 1) & Mid(ar1(3, i + i1 - 1), i4, 1)) = ar2(Mid(ar1(1, i + i1 - 1), i2, 1) & Mid(ar1(2, i + i1 - 1), i3, 1) & Mid(ar1(3, i + i1 - 1), i4, 1)) + 1
    
16.                     Next i4
    
17.                 Next i3
    
18.             Next i2
    
19.         Next i1
    
20.         For l = 0 To 999
    
21.             If ar2(l) > 2 Then
    
22.                 k = k + 1
    
23.                 ar3(k, 1) = "'" & Right("000" & l, 3)
    
24.             End If
    
25.         Next l
    
26.         Erase ar2
    
27.     Next i
    
28.     [b1].Resize(k) = ar3
    
29. End Sub

复制代码

suye1010

1. Sub ExtractData()
   
2. Dim d0, d, i As Long, j As Long, k As Long, l As Integer, m As Integer, n As Integer, arr, TempNo, TempArr, x, y
   
3. arr = Range("G2:IS4")
   
4. Set d0 = CreateObject("Scripting.Dictionary")
   
5. Set d = CreateObject("Scripting.Dictionary")
   
6. For j = 1 To UBound(arr, 2) - 3 Step 4
   
7.     For k = 0 To 3
   
8.         For l = 1 To 5
   
9.             For m = 1 To 5
   
10.                 For n = 1 To 5
    
11.                     TempNo = Mid(arr(1, j + k), l, 1) & Mid(arr(2, j + k), m, 1) & Mid(arr(3, j + k), n, 1)
    
12.                     d0(TempNo) = d0(TempNo) + 1
    
13.                     If d0(TempNo) > 1 Then d((j \ 4 + 1) & " " & TempNo) = d0(TempNo) '在满足条件的数据前添加数加不同组别标识
    
14.                 Next n
    
15.             Next m
    
16.         Next l
    
17.     Next k
    
18. d0.RemoveAll
    
19. Next j
    
20. ReDim TempArr(1 To d.Count, 1 To 2)
    
21. For Each x In Application.Transpose(d.keys)
    
22.     y = y + 1
    
23.     TempArr(y, 1) = Split(x)(0)
    
24.     TempArr(y, 2) = Split(x)(1)
    
25. Next
    
26. Columns("A:C").ClearContents
    
27. Range("A2").Resize(d.Count, 1) = Application.Index(TempArr, , 1) '组别
    
28. Range("B2").Resize(d.Count, 1) = Application.Index(TempArr, , 2) '数字组合
    
29. Range("C2").Resize(d.Count, 1) = Application.Transpose(d.items)  '出现次数
    
30. End Sub

复制代码

组合提取.zip (116.45 KB, 下载次数: 5)

2013-2-7 11:01 上传

点击文件名下载附件