求助代码,各省份不重复月份个数

lzqmsy

求助代码,各省份不重复月份个数,我已经写了代码,但由于刚学字典数组方面的知识,写的很麻烦,不一定符合规则,求助各位老师帮助,多谢了!!!请看附件 求助代码( ).rar (10.79 KB, 下载次数: 11)

2016-11-25 17:24 上传

点击文件名下载附件

jsgj2023

关注一下，看看能否在鲁班门前弄一下斧。

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("sheet1")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:b" & r)
   
9.     For i = 1 To UBound(arr)
   
10.       If Not d.exists(arr(i, 1)) Then
    
11.         Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
    
12.       End If
    
13.       d(arr(i, 1))(arr(i, 2)) = d(arr(i, 1))(arr(i, 2)) + 1
    
14.     Next
    
15.     m = 2
    
16.     For Each aa In d.keys
    
17.       .Cells(m, 6) = aa
    
18.       .Cells(m, 7) = d(aa).Count
    
19.       .Cells(m, 8) = Application.Sum(d(aa).items)
    
20.       m = m + 1
    
21.     Next
    
22.   End With
    
23. End Sub
    

复制代码

chxw68

代码不一定精练，供楼主参考。

microyip

1. Sub 不重复月份数()
   
2. Dim d As Object, d1 As Object, d2 As Object, i%, Arr
   
3. Set d = CreateObject("scripting.dictionary")
   
4. Set d1 = CreateObject("scripting.dictionary")
   
5. Set d2 = CreateObject("scripting.dictionary")
   
6. Range("F2:P8").ClearContents
   
7. Arr = [A1].CurrentRegion.Value
   
8. For i = 2 To UBound(Arr)
   
9.     If Not d.Exists(Arr(i, 1) & Arr(i, 2)) Then
   
10.         d(Arr(i, 1) & Arr(i, 2)) = 0
    
11.         d1(Arr(i, 1)) = d1(Arr(i, 1)) + 1
    
12.     End If
    
13.     d2(Arr(i, 1)) = d2(Arr(i, 1)) + 1
    
14. Next
    
15. Range("F2").Resize(d1.Count, 1) = Application.Transpose(d1.Keys)
    
16. Range("G2").Resize(d1.Count, 1) = Application.Transpose(d1.Items)
    
17. Range("H2").Resize(d1.Count, 1) = Application.Transpose(d2.Items)
    
18. End Sub

复制代码

chxw68

1. Sub test111()
   
2.   Dim cnn As New ADODB.Connection
   
3.   Dim rs As New ADODB.Recordset
   
4.   Dim sql As String
   
5.   Dim mybook As String
   
6.   mybook = ThisWorkbook.FullName
   
7.   With cnn
   
8.     If Application.Version = "11.0" Then
   
9.       .Provider = "microsoft.jet.oledb.4.0"
   
10.       .ConnectionString = "extended properties=""excel 8.0;HDR=YES;IMEX=1"";data source=" & mybook
    
11.     Else
    
12.       .Provider = "microsoft.ACE.oledb.12.0"
    
13.       .ConnectionString = "extended properties=""excel 12.0;HDR=YES;IMEX=1"";data source=" & mybook
    
14.     End If
    
15.     .Open
    
16.   End With
    
17.   sql = "select 省份,count(省份) as 不重复月份数,sum(信息条数) as 信息条数 from (select 省份,月份,count(省份) as 信息条数 from [sheet1$a1:b] group by 省份,月份) group by 省份"
    
18.   rs.Open sql, cnn, adOpenKeyset, adLockOptimistic
    
19.   With Worksheets("sheet2")
    
20.     .Cells.Delete
    
21.     For j = 0 To rs.Fields.Count - 1
    
22.       .Cells(1, j + 1) = rs.Fields(j).Name
    
23.     Next
    
24.     .Range("a2").CopyFromRecordset rs
    
25.   End With
    
26. End Sub
    

复制代码

chxw68

楼主可能是学习字典用法。其实用SQL也是个不错的选择。

microyip

附上附件以供参考

lzqmsy

chxw68 发表于 2016-11-25 17:34

谢谢老师,您帮我很多了,再次谢谢,sql的我会,但稍慢些,数据源2万多行,我用sql做的,用时0.8秒左右,用字典做的0.4秒左右,另外确实想学字典数组方面的知识,谢谢您不吝赐教!!!

lzqmsy

microyip 发表于 2016-11-25 17:41

谢谢,我慢慢理解一下,再次谢谢!!!