[已解决]求助vba

lmknj

求数.rar (29.9 KB, 下载次数: 14)

2013-4-15 21:50 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-4-15 22:19

1. Sub test()
   
2.     Dim lCol&
   
3.     Dim lRept&
   
4.     Dim result, arr
   
5.     Dim lLastRow&
   
6.     Columns(1) = ""
   
7.     lLastRow = 1
   
8.     For lCol = 9 To 16
   
9.         arr = Range(Cells(3, lCol), Cells(10000, lCol))
   
10.         result = CheckRept(arr, Cells(1, lCol))
    
11.         If IsArray(result) Then
    
12.             Cells(lLastRow, 1).Resize(UBound(result)) = WorksheetFunction.Transpose(result)
    
13.             lLastRow = lLastRow + UBound(result)
    
14.         End If
    
15.     Next
    
16. End Sub
    
17. 
    
18. Function CheckRept(arr, lCondition As Long)
    
19.     If Not IsArray(arr) Then CheckRept = False: Exit Function
    
20.     If lCondition <= 0 Then CheckRept = False: Exit Function
    
21.     Dim lCount&
    
22.     Dim result()
    
23. 
    
24.     Dim dic As Object
    
25. 
    
26.     Set dic = CreateObject("scripting.dictionary")
    
27.     Dim i As Long
    
28.     Dim keys
    
29.     ReDim result(1 To 1)
    
30.     For i = LBound(arr) To UBound(arr)
    
31.         dic(arr(i, 1)) = dic(arr(i, 1)) + 1
    
32.     Next
    
33.     For Each keys In dic.keys
    
34.         If dic(keys) = lCondition Then
    
35.             lCount = lCount + 1
    
36.             ReDim Preserve result(1 To lCount)
    
37.             result(lCount) = "'" & keys
    
38.         End If
    
39.     Next
    
40.     If lCount > 1 Then
    
41.         CheckRept = result
    
42.     Else
    
43.         CheckRept = False
    
44.     End If
    
45. End Function

复制代码

跳转到最佳答案楼层

hwc2ycy

你这题哪来的啊，怎么老是有这种题型求助呢。

lmknj

hwc2ycy 发表于 2013-4-15 21:55
你这题哪来的啊，怎么老是有这种题型求助呢。

因为觉得很新鲜呀,

无聊的疯子

lmknj 发表于 2013-4-15 22:01
因为觉得很新鲜呀,

我记得这题好像解了好多次了吧???

直接修改里面的数据就能处理了嘛,干嘛还重复发贴呢?

lmknj

无聊的疯子 发表于 2013-4-15 22:04
我记得这题好像解了好多次了吧???

直接修改里面的数据就能处理了嘛,干嘛还重复发贴呢?

巳前的运行有点慢,我要重复几百次,要20个小时才能运行完,只有再问,

hwc2ycy

1. Sub test()
   
2.     Dim lCol&
   
3.     Dim lRept&
   
4.     Dim result, arr
   
5.     Dim lLastRow&
   
6.     Columns(1) = ""
   
7.     lLastRow = 1
   
8.     For lCol = 9 To 16
   
9.         arr = Range(Cells(3, lCol), Cells(10000, lCol))
   
10.         result = CheckRept(arr, Cells(1, lCol))
    
11.         If IsArray(result) Then
    
12.             Cells(lLastRow, 1).Resize(UBound(result)) = WorksheetFunction.Transpose(result)
    
13.             lLastRow = lLastRow + UBound(result)
    
14.         End If
    
15.     Next
    
16. End Sub
    
17. 
    
18. Function CheckRept(arr, lCondition As Long)
    
19.     If Not IsArray(arr) Then CheckRept = False: Exit Function
    
20.     If lCondition <= 0 Then CheckRept = False: Exit Function
    
21.     Dim lCount&
    
22.     Dim result()
    
23. 
    
24.     Dim dic As Object
    
25. 
    
26.     Set dic = CreateObject("scripting.dictionary")
    
27.     Dim i As Long
    
28.     Dim keys
    
29.     ReDim result(1 To 1)
    
30.     For i = LBound(arr) To UBound(arr)
    
31.         dic(arr(i, 1)) = dic(arr(i, 1)) + 1
    
32.     Next
    
33.     For Each keys In dic.keys
    
34.         If dic(keys) = lCondition Then
    
35.             lCount = lCount + 1
    
36.             ReDim Preserve result(1 To lCount)
    
37.             result(lCount) = "'" & keys
    
38.         End If
    
39.     Next
    
40.     If lCount > 1 Then
    
41.         CheckRept = result
    
42.     Else
    
43.         CheckRept = False
    
44.     End If
    
45. End Function

复制代码

hwc2ycy

你到底多少数据啊，要运行20几个小时。

lmknj

hwc2ycy 发表于 2013-4-15 22:19
你到底多少数据啊，要运行20几个小时。

有100个薄,每个薄有400m,数据太多

lmknj

hwc2ycy 发表于 2013-4-15 22:19

谢谢你这次非常快

su45

lmknj 发表于 2013-4-15 22:35
有100个薄,每个薄有400m,数据太多

100个400M的Excel文件？！那不是40G！太吓人了！咱还没见过400M的Excel文件呢！4M的Excel文件咱都觉得大！