[已解决]再求另一个问题

GYUHJ

BOOK1.rar (296.66 KB, 下载次数: 5)

2014-2-8 13:32 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

CheryBTL

2014-2-8 14:22

提取的数据有重复要不去重呢？
未去重的数据，请测试：

1. Sub test()
   
2.     Dim ar, re, temp
   
3.     Dim i As Integer, j As Long, Cnt As Long
   
4.     ar = Sheets(1).Range("N3").CurrentRegion
   
5.     ReDim re(1 To 9999, 1 To 1)
   
6.     For i = 1 To UBound(ar, 2) - 3
   
7.         ReDim temp(999) As Integer
   
8.         For j = 1 To UBound(ar) - 3
   
9.             For k = 0 To 3
   
10.                 If ar(j, i + k) <> "" Then
    
11.                     temp(Val(ar(j, i + k))) = temp(Val(ar(j, i + k))) + 1
    
12.                 End If
    
13.             Next
    
14.         Next
    
15.         For j = 0 To 999
    
16.             If temp(j) > 20 Then
    
17.                 Cnt = Cnt + 1
    
18.                 re(Cnt, 1) = Format(j, "000")
    
19.             End If
    
20.         Next
    
21.     Next
    
22.     Sheets(1).[a1:a65536].ClearContents
    
23.     If Cnt > 0 Then
    
24.         Sheets(1).[a1].Resize(Cnt) = re
    
25.     Else
    
26.         MsgBox "无匹配数据"
    
27.     End If
    
28. End Sub

复制代码

跳转到最佳答案楼层

CheryBTL

提取的数据有重复要不去重呢？
未去重的数据，请测试：

1. Sub test()
   
2.     Dim ar, re, temp
   
3.     Dim i As Integer, j As Long, Cnt As Long
   
4.     ar = Sheets(1).Range("N3").CurrentRegion
   
5.     ReDim re(1 To 9999, 1 To 1)
   
6.     For i = 1 To UBound(ar, 2) - 3
   
7.         ReDim temp(999) As Integer
   
8.         For j = 1 To UBound(ar) - 3
   
9.             For k = 0 To 3
   
10.                 If ar(j, i + k) <> "" Then
    
11.                     temp(Val(ar(j, i + k))) = temp(Val(ar(j, i + k))) + 1
    
12.                 End If
    
13.             Next
    
14.         Next
    
15.         For j = 0 To 999
    
16.             If temp(j) > 20 Then
    
17.                 Cnt = Cnt + 1
    
18.                 re(Cnt, 1) = Format(j, "000")
    
19.             End If
    
20.         Next
    
21.     Next
    
22.     Sheets(1).[a1:a65536].ClearContents
    
23.     If Cnt > 0 Then
    
24.         Sheets(1).[a1].Resize(Cnt) = re
    
25.     Else
    
26.         MsgBox "无匹配数据"
    
27.     End If
    
28. End Sub

复制代码

CheryBTL

按从左到右提取并按满足条件的顺序提取的不重复数据，请测试：
Cnt这个参数及相关的赋值可以不用，删除了。

1. Sub test()
   
2.     Dim ar, re, temp, d As Object
   
3.     Dim i As Integer, j As Long
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     ar = Sheets(1).Range("N3").CurrentRegion
   
6.     ReDim re(1 To 9999, 1 To 1)
   
7.     For i = 1 To UBound(ar, 2) - 3
   
8.         ReDim temp(999) As Integer
   
9.         For j = 1 To UBound(ar) - 3
   
10.             For k = 0 To 3
    
11.                 If ar(j, i + k) <> "" Then
    
12.                     temp(Val(ar(j, i + k))) = temp(Val(ar(j, i + k))) + 1
    
13.                 End If
    
14.             Next
    
15.         Next
    
16.         For j = 0 To 999
    
17.             If temp(j) > 20 Then
    
18.                 d(Format(j, "000")) = ""
    
19.             End If
    
20.         Next
    
21.     Next
    
22.     Sheets(1).[a1:a65536].ClearContents
    
23.     If Cnt > 0 Then
    
24.         Sheets(1).[a1].Resize(d.Count) = Application.Transpose(d.keys)
    
25.     Else
    
26.         MsgBox "无匹配数据"
    
27.     End If
    
28. End Sub

复制代码