[已解决]求助

bhgyuj123

这个只能算一个表的数据,如果要改成用全部表的数据要怎改代码?

sub 总5()
    Set d1 = CreateObject("Scripting.Dictionary")
    Set d2 = CreateObject("Scripting.Dictionary")
    Set d3 = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    For j = 14 To 109
        Row1 = Cells(Rows.Count, j).End(xlUp).Row
        Arr1 = Range(Cells(3, j), Cells(Row1, j))
        For i = 1 To UBound(Arr1)
            d1(Arr1(i, 1)) = d1(Arr1(i, 1)) + 1
        Next i
        Arr2 = d1.Keys
        Arr3 = d1.Items
        For i = 0 To UBound(Arr3)
            If Arr3(i) > 8 Then d2(Arr2(i)) = d2(Arr2(i)) + 1
        Next i
        d1.RemoveAll
        Erase Arr2
        Erase Arr3
    Next j
    Arr11 = d2.Keys
    Arr12 = d2.Items
    For i = 0 To UBound(Arr12)
        If Arr12(i) > 3 Then d3(Arr11(i)) = d3(Arr11(i)) + 1
    Next i
    ARR21 = d3.Keys
    ARR22 = d3.Items
    Sheets("1").Range("B5000").End(xlUp).Offset(1, 0).Resize(UBound(ARR22) + 1, 1) = Application.WorksheetFunction.Transpose(ARR21)  
End sub

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-12-28 17:31

bhgyuj123 发表于 2013-12-28 17:09
所有表汇成一个

1. Sub 总5()
   
2.     Set d1 = CreateObject("Scripting.Dictionary")
   
3.     Set d2 = CreateObject("Scripting.Dictionary")
   
4.     Set d3 = CreateObject("Scripting.Dictionary")
   
5.     For Each sht In Worksheets
   
6.         If sht.Name <> "1" Then
   
7.             With sht
   
8.                 On Error Resume Next
   
9.                 For j = 14 To 109
   
10.                     Row1 = .Cells(Rows.Count, j).End(xlUp).Row
    
11.                     Arr1 = .Range(Cells(3, j), .Cells(Row1, j))
    
12.                     For i = 1 To UBound(Arr1)
    
13.                         d1(Arr1(i, 1)) = d1(Arr1(i, 1)) + 1
    
14.                     Next i
    
15.                     Arr2 = d1.Keys
    
16.                     Arr3 = d1.Items
    
17.                     For i = 0 To UBound(Arr3)
    
18.                         If Arr3(i) > 8 Then d2(Arr2(i)) = d2(Arr2(i)) + 1
    
19.                     Next i
    
20.                     d1.RemoveAll
    
21.                     Erase Arr2
    
22.                     Erase Arr3
    
23.                 Next j
    
24.                 Arr11 = d2.Keys
    
25.                 Arr12 = d2.Items
    
26.                 For i = 0 To UBound(Arr12)
    
27.                     If Arr12(i) > 3 Then d3(Arr11(i)) = d3(Arr11(i)) + 1
    
28.                 Next i
    
29.             End With
    
30. 
    
31.         End If
    
32.     Next
    
33. 
    
34.     ARR21 = d3.Keys
    
35.     ARR22 = d3.Items
    
36.     Set d3 = Nothing
    
37.     Set d2 = Nothing
    
38.     Set d1 = Nothing
    
39.     Sheets("1").Range("B5000").End(xlUp).Offset(1, 0).Resize(UBound(ARR22) + 1, 1) = Application.WorksheetFunction.Transpose(ARR21)
    
40. End Sub

复制代码

没附件，我这就没有测试了，你试试。

跳转到最佳答案楼层

hwc2ycy

是每个表单独算还是所有的表汇成一个？

bhgyuj123

hwc2ycy 发表于 2013-12-28 16:56
是每个表单独算还是所有的表汇成一个？

所有表汇成一个

hwc2ycy

bhgyuj123 发表于 2013-12-28 17:09
所有表汇成一个

1. Sub 总5()
   
2.     Set d1 = CreateObject("Scripting.Dictionary")
   
3.     Set d2 = CreateObject("Scripting.Dictionary")
   
4.     Set d3 = CreateObject("Scripting.Dictionary")
   
5.     For Each sht In Worksheets
   
6.         If sht.Name <> "1" Then
   
7.             With sht
   
8.                 On Error Resume Next
   
9.                 For j = 14 To 109
   
10.                     Row1 = .Cells(Rows.Count, j).End(xlUp).Row
    
11.                     Arr1 = .Range(Cells(3, j), .Cells(Row1, j))
    
12.                     For i = 1 To UBound(Arr1)
    
13.                         d1(Arr1(i, 1)) = d1(Arr1(i, 1)) + 1
    
14.                     Next i
    
15.                     Arr2 = d1.Keys
    
16.                     Arr3 = d1.Items
    
17.                     For i = 0 To UBound(Arr3)
    
18.                         If Arr3(i) > 8 Then d2(Arr2(i)) = d2(Arr2(i)) + 1
    
19.                     Next i
    
20.                     d1.RemoveAll
    
21.                     Erase Arr2
    
22.                     Erase Arr3
    
23.                 Next j
    
24.                 Arr11 = d2.Keys
    
25.                 Arr12 = d2.Items
    
26.                 For i = 0 To UBound(Arr12)
    
27.                     If Arr12(i) > 3 Then d3(Arr11(i)) = d3(Arr11(i)) + 1
    
28.                 Next i
    
29.             End With
    
30. 
    
31.         End If
    
32.     Next
    
33. 
    
34.     ARR21 = d3.Keys
    
35.     ARR22 = d3.Items
    
36.     Set d3 = Nothing
    
37.     Set d2 = Nothing
    
38.     Set d1 = Nothing
    
39.     Sheets("1").Range("B5000").End(xlUp).Offset(1, 0).Resize(UBound(ARR22) + 1, 1) = Application.WorksheetFunction.Transpose(ARR21)
    
40. End Sub

复制代码

没附件，我这就没有测试了，你试试。