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

lzqmsy

再次求助代码(By.Micro).rar (11.58 KB, 下载次数: 4)

2016-11-27 17:08 上传

点击文件名下载附件

microyip老师麻烦你了

lzqmsy

microyip 发表于 2016-11-25 17:45
附上附件以供参考

老师,您好,还要麻烦您,请有时间时看看21楼的附件,再次谢谢!!!

microyip

lzqmsy 发表于 2016-11-27 17:12
老师,您好,还要麻烦您,请有时间时看看21楼的附件,再次谢谢!!!

你的期初又怎样出现的？

lzqmsy

microyip 发表于 2016-11-27 17:20
你的期初又怎样出现的？

期初就是原表的数据,没有重复,肯定在数据库省份内

microyip

lzqmsy 发表于 2016-11-27 17:56
期初就是原表的数据,没有重复,肯定在数据库省份内

没见到有这个信息

lzqmsy

microyip 发表于 2016-11-27 18:33
没见到有这个信息

老师您好,期初信息就在期初表里呀
省份
北京
上海
天津

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. Set d3 = CreateObject("scripting.dictionary") '期初数\最终数组
   
7. 
   
8. Arr = [A1].CurrentRegion.Value
   
9. For i = 2 To UBound(Arr)
   
10.     If Not d.Exists(Month(Arr(i, 1)) & Arr(i, 2)) Then
    
11.         d(Month(Arr(i, 1)) & Arr(i, 2)) = 0
    
12.         d1(Arr(i, 2)) = d1(Arr(i, 2)) + 1
    
13.         d3(Arr(i, 2)) = 0
    
14.     End If
    
15.     d2(Arr(i, 2)) = d2(Arr(i, 2)) + 1
    
16. Next
    
17. Range("D2").CurrentRegion.Offset(1).ClearContents
    
18. Range("D2").Resize(d1.Count, 1) = Application.Transpose(d1.Keys)
    
19. Range("E2").Resize(d1.Count, 1) = Application.Transpose(d1.Items)
    
20. Range("F2").Resize(d1.Count, 1) = Application.Transpose(d2.Items)
    
21. Arr = Sheets("期初").[A1].CurrentRegion.Value
    
22. For i = 2 To UBound(Arr)
    
23.     If d3.Exists(Arr(i, 1)) Then d3(Arr(i, 1)) = 1
    
24. Next
    
25. Range("G2").Resize(d1.Count, 1) = Application.Transpose(d3.Items)
    
26. For Each Arr In d1.Keys
    
27.     d3(Arr) = d3(Arr) * 2 + d2(Arr) + d3(Arr)
    
28. Next
    
29. Range("J2").CurrentRegion.Offset(1).ClearContents
    
30. Range("J2").Resize(d1.Count, 1) = Application.Transpose(d1.Keys)
    
31. Range("K2").Resize(d1.Count, 1) = Application.Transpose(d3.Items)
    
32. End Sub

复制代码

microyip

附上附件以供参考

lzqmsy

microyip 发表于 2016-11-27 18:55
附上附件以供参考

谢谢老师,是这样的,但是我不需要把数据写在表里,只需写在数组里就行了,再次谢谢老师!!!

LMY123

ado与字典，不重复