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

Kaohsing · 发表于 2016-11-25 20:14

你试试行不？
Sub getData()


  Dim d As Object, rMax%, arr
  Dim i%, dtemp, dkey, data()

  Set d = CreateObject("scripting.dictionary")
  rMax = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
  arr = Sheet1.Range("a2:b" & rMax)
  Set d("ALL") = CreateObject("scripting.dictionary")

For i = 1 To UBound(arr)
   If Not d.exists(arr(i, 1)) Then Set d(arr(i, 1)) = CreateObject("scripting.dictionary")
         Set dtemp = d(arr(i, 1))
   If Not dtemp.exists(arr(i, 2)) Then Set dtemp(arr(i, 2)) = CreateObject("scripting.dictionary")
      Set dtemp = dtemp(arr(i, 2))

   Set dtemp = d("ALL")
   If Not dtemp.exists(arr(i, 1)) Then Set dtemp(arr(i, 1)) = CreateObject("scripting.dictionary")
      Set dtemp = dtemp(arr(i, 1))
      dtemp(arr(i, 1)) = dtemp(arr(i, 1)) + 1
Next

   ReDim Preserve data(1 To d.Count - 1, 1 To 3)
   For i = 1 To d.Count - 1
   dkey = d.keys
   data(i, 1) = dkey(i)
   data(i, 2) = d(dkey(i)).Count
   data(i, 3) = d("ALL")(dkey(i)).items()(0)
   Next

   Sheet1.[F2].Resize(UBound(data) - 1, UBound(data, 2)) = data
Set d = Nothing
End Sub

lzqmsy · 发表于 2016-11-25 22:29

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

试过了,速度很快,1万多行数据,仅用0.18秒,再次谢谢

kszcs · 发表于 2016-11-25 22:47

Kaohsing 发表于 2016-11-25 20:14
你试试行不？
Sub getData()

缺少吉林，怎么？

lzqmsy · 发表于 2016-11-25 23:16

Kaohsing 发表于 2016-11-25 20:14
你试试行不？
Sub getData()

谢谢你,是我要的效果,不是我想要的代码,速度太慢了

zjgwzj · 发表于 2016-11-27 08:32

可以使用数据透视表，操作更简单

fxl447098457 · 发表于 2016-11-27 09:49

Sub test()
Dim sd As Object, d As Object, Ar, brr(), i&, j&, k&
t = Timer
Ar = Range("a2:b" & Cells(Rows.Count, 1).End(3).Row)
Set sd = CreateObject("scripting.dictionary")
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(Ar)
If Not sd.exists(Ar(i, 1)) Then
k = k + 1: sd(Ar(i, 1)) = ""
ReDim Preserve brr(1 To 2, 1 To k)
For j = 1 To UBound(Ar)
If Ar(i, 1) = Ar(j, 1) Then
brr(2, k) = brr(2, k) + 1
If Not d.exists(Ar(j, 1) & "|" & Ar(j, 2)) Then
d(Ar(j, 1) & "|" & Ar(j, 2)) = ""
brr(1, k) = brr(1, k) + 1
End If
End If
Next j
End If
Next i
Range("m2").Resize(sd.Count) = Application.Transpose(sd.Keys)
Range("n2").Resize(k, 2) = Application.Transpose(brr)
Set sd = Nothing
Set d = Nothing
End Sub

复制代码

lzqmsy · 发表于 2016-11-27 15:42

zjgwzj 发表于 2016-11-27 08:32
可以使用数据透视表，操作更简单

是程序的一部分,所以不能使用数据透视表,谢谢你

lzqmsy · 发表于 2016-11-27 15:56

fxl447098457 发表于 2016-11-27 09:49

谢谢你再次回复,你的程序没问题,能够得到想要的结果,就是速度太慢,数据源11427行,月份列是日期时,你的程序用时5秒,目前我求助来的最快的代码用时0.11秒

microyip · 发表于 2016-11-27 16:09

lzqmsy 发表于 2016-11-27 15:56
谢谢你再次回复,你的程序没问题,能够得到想要的结果,就是速度太慢,数据源11427行,月份列是日期时,你的程 ...

哪段是0.11秒？我也学习一下

lzqmsy · 发表于 2016-11-27 17:06

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

		自动登录	找回密码
密码			免费注册

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