[已解决]用纯粹的字典与数组解决仅仅分类的问题

不解木野狐 · 发表于 2012-1-30 20:54

Sub 字典与数组替代筛选()
Dim DIC As New Dictionary, RAG As Range, X, Y, XX
For Each RAG In Range("B5:B" & Range("B65536").End(3).Row)
DIC(RAG.Value) = ""
Next
Dim ARR, ARR1(1 To 10000)
ARR = Range("A5:AB" & Range("AB65536").End(3).Row)
On Error Resume Next
For X = 1 To DIC.Count
For Y = 1 To UBound(ARR)
If DIC.Keys(X) = ARR(Y, 2) Then
XX = XX + 1
ARR1(XX) = ARR(Y, 2)
End If
Next
Next
Stop
End Sub

复制代码

不想用工作表的筛选，也是想好好的学一下字典与数组，如图所示，派工单按发生的顺序先后录入，我想做的是，相同的人名都排在一起，也就是根据人名重新分类，但无需汇总，我发个我做的代码，但完成不下去了........
   我先说说我的思路：
      1.先根据工作表的B列，生成字典的不重复的人名KEYS
      2.再把工作表装入一个数组 ARR
      3.循环...循环...判断字典的KEYS 是否和数组的第二列（也就是人名列）的某个值相等，如果相等的话，那么就把数组的整列都放入一个新数组ARR1
   4.生成的新的ARR1 应该是和原来的ARR 维数与上下标完全一至的，最后覆盖整个工作表，即完成整个工作表的分类。
      我的代码仅仅对人名列一列进行分类就进行不下去了，{:4112:}

最佳答案

月排行榜 / 总排行榜

sunjing-zxl

2012-1-30 21:06

Sub aa()
Dim arr, i As Long, j As Long, n As Long
Dim arr1, arr2, Ro As Long, Co As Long
Dim d As New Dictionary
Dim d1 As New Dictionary
arr = Range("A2:D9")
For i = 1 To UBound(arr)
n = d.Count
If d.Exists(arr(i, 2)) Then
d(arr(i, 2)) = Array(d(arr(i, 2))(0), d(arr(i, 2))(1) + 1)
Else
d.Add arr(i, 2), Array(n + 1, 1)
End If
Next i
ReDim arr1(1 To UBound(arr), 1 To UBound(arr, 2))
arr2 = d.Items
For i = 1 To UBound(arr)
d1(arr(i, 2)) = d1(arr(i, 2)) + 1
For j = 1 To d(arr(i, 2))(0)
If j = 1 Then
Ro = 0
Else
Ro = Ro + arr2(j - 2)(1)
End If
Next j
Ro = Ro + d1(arr(i, 2))
For Co = 1 To 4
arr1(Ro, Co) = arr(i, Co)
Next Co
Next i
Range("F2").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
End Sub

复制代码

模拟附件.rar (10.08 KB, 下载次数: 37)

搁浅2008 · 发表于 2012-1-30 21:03

没看明白

sunjing-zxl · 发表于 2012-1-30 21:06

这个最佳答案由 sunjing-zxl 给出，感谢 sunjing-zxl 的回答。

单击隐藏图章

Sub aa()
Dim arr, i As Long, j As Long, n As Long
Dim arr1, arr2, Ro As Long, Co As Long
Dim d As New Dictionary
Dim d1 As New Dictionary
arr = Range("A2:D9")
For i = 1 To UBound(arr)
n = d.Count
If d.Exists(arr(i, 2)) Then
d(arr(i, 2)) = Array(d(arr(i, 2))(0), d(arr(i, 2))(1) + 1)
Else
d.Add arr(i, 2), Array(n + 1, 1)
End If
Next i
ReDim arr1(1 To UBound(arr), 1 To UBound(arr, 2))
arr2 = d.Items
For i = 1 To UBound(arr)
d1(arr(i, 2)) = d1(arr(i, 2)) + 1
For j = 1 To d(arr(i, 2))(0)
If j = 1 Then
Ro = 0
Else
Ro = Ro + arr2(j - 2)(1)
End If
Next j
Ro = Ro + d1(arr(i, 2))
For Co = 1 To 4
arr1(Ro, Co) = arr(i, Co)
Next Co
Next i
Range("F2").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
End Sub

复制代码

模拟附件.rar (10.08 KB, 下载次数: 37)

TTTTT · 发表于 2012-1-30 21:09

为什么楼主不把附件一起发上来？

不解木野狐 · 发表于 2012-1-30 23:20

TTTTT 发表于 2012-1-30 21:09
为什么楼主不把附件一起发上来？

俺有点懒，还想保密啊{:4812:}

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

[已解决]用纯粹的字典与数组解决仅仅分类的问题

评分