[分享]字典+数组的多列数据不重复值查询.应用实例

tiger744990

本例的靓点:字典+数组,两种不同的处理方式;
较好地表达了,字典,数组,的应用方法.
仔细体会一下,字典+数组,的不同运用.

'方法一,是Long_III版的(有注释).

Private Sub CommandButton1_Click()
Dim ds
Dim i&, irow&, m&, m1&, s&
Dim arr, Xarr(), Yarr()
Dim aa As Double
aa = Timer
Range("f:i").ClearContents    '清除f：i列的内容
Application.ScreenUpdating = False
Set ds = CreateObject("scripting.dictionary")
m = 1
For j = 1 To 4    '在A～D列里做一个循环
irow = Cells(65536, j).End(xlUp).Row
arr = Range(Cells(1, j), Cells(irow, j))    '用数组取单元格的值
On Error Resume Next
For i = 1 To irow
If arr(i, 1) <> "" Then
ds.Add arr(i, 1), m
If Err.Number = 0 Then
ReDim Preserve Xarr(1 To 2, 1 To m)
Xarr(1, m) = arr(i, 1)
Xarr(2, m) = Choose(j, "A", "B", "C", "D")
m = m + 1
Else
s = ds(arr(i, 1))
Xarr(2, s) = Xarr(2, s) & Choose(j, "A", "B", "C", "D")    '出现重复的时候就统计它的列数
End If
Err.Clear    '清除错误数字
End If
Next
Next
On Error GoTo 0    '重新恢复错误捕捉功能，以后出现错误还是会报错
'重新统计各种出现情况的次数
ds.RemoveAll    '清除字典里的所有数据
m1 = 1
On Error Resume Next    '此过程与上一个过程极其相似
For i = 1 To m - 1
ds.Add Xarr(2, i), m1
If Err.Number = 0 Then
ReDim Preserve Yarr(1 To 2, 1 To m1)
Yarr(1, m1) = Xarr(2, i)
Yarr(2, m1) = 1
m1 = m1 + 1
Else
s = ds(Xarr(2, i))
Yarr(2, s) = Yarr(2, s) + 1    '次数就是加1的效果
End If
Err.Clear
Next
On Error GoTo 0
[f1].Resize(m - 1, 2) = Application.WorksheetFunction.Transpose(Xarr)    '计算各个数在ABCD列中的出现情况
[h1].Resize(m1 - 1, 2) = Application.WorksheetFunction.Transpose(Yarr)    '计算各种出现情况的次数
Application.ScreenUpdating = True
MsgBox "Total:=" & Format(Timer - aa, "0.00") & "s"
End Sub

'方法二,是本人所写.代码相对容易理解.

Sub tiger744990()
Dim dic As Object, i&, n&, arr, Xarr, str As String, j As Byte
Dim aa As Double
aa = Timer
Set dic = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
With dic
For j = 1 To 4
With Sheet1
n = .Cells(65536, j).End(xlUp).Row: arr = .Range(.Cells(1, j), .Cells(n, j))
End With
For i = 1 To n
If Len(arr(i, 1)) <> 0 Then
str = Choose(j, "A", "B", "C", "D")
If Not .exists(arr(i, 1)) Then
.Add arr(i, 1), str
Else
.Item(arr(i, 1)) = .Item(arr(i, 1)) & str
End If
End If
Next
Next
Xarr = .Items
Sheet1.[f:i].ClearContents
Sheet1.[f1].Resize(.Count, 1) = WorksheetFunction.Transpose(.keys)
Sheet1.[g1].Resize(.Count, 1) = WorksheetFunction.Transpose(.Items)
.RemoveAll
For i = 0 To UBound(Xarr)
If Not .exists(Xarr(i)) Then .Add Xarr(i), 1 Else .Item(Xarr(i)) = .Item(Xarr(i)) + 1
Next
Sheet1.[h1].Resize(.Count, 1) = WorksheetFunction.Transpose(.keys)
Sheet1.[i1].Resize(.Count, 1) = WorksheetFunction.Transpose(.Items)
End With
Application.ScreenUpdating = True
Set dic = Nothing
MsgBox "Total:=" & Format(Timer - aa, "0.00") & "s"
End Sub

ulXkLYST.rar (26.64 KB, 下载次数: 1743)

2007-11-21 18:15 上传

点击文件名下载附件
[分享]字典+数组.应用实例

[此贴子已经被作者于2007-11-22 13:08:28编辑过]

tiger744990

tiger744990

再来一个:

Sub tiger744990()
Dim dic As Object, arr, arr1, i%, j%, n%
Dim aa As Double
aa = Timer
Application.ScreenUpdating = False
Set dic = CreateObject("Scripting.Dictionary")
n = Cells(65536, 1).End(xlUp).Row
arr = [a1].CurrentRegion.Value
For i = 2 To n
If Not dic.exists(arr(i, 2) & arr(i, 3)) Then dic.Add arr(i, 2) & arr(i, 3), ""
Next
arr1 = dic.keys
ReDim temp(0 To dic.Count - 1, 1 To 7)
For j = 0 To dic.Count - 1
For i = 2 To n
If arr(i, 2) & arr(i, 3) = arr1(j) Then
temp(j, 1) = arr(i, 1)
temp(j, 2) = arr(i, 2)
temp(j, 3) = arr(i, 3)
temp(j, 4) = arr(i, 4)
temp(j, 5) = temp(j, 5) + arr(i, 5)
temp(j, 6) = temp(j, 6) + arr(i, 6)
temp(j, 7) = temp(j, 7) + arr(i, 7)
End If
Next
Next
Sheet2.[a1:g1] = Sheet1.[a1:g1].Value
Sheet2.[a2].Resize(dic.Count, 7) = temp
Set dic = Nothing
Application.ScreenUpdating = True
MsgBox "Total:= " & Format(Timer - aa, "0.00") & "s"
End Sub

ubound

thanks

wsri

应该给标题加一个清晰的说明：字典+数组的多列数据不重复值查询.应用实例。否则就给人看的一头雾水，不知道该示例到底是做什么的！

tiger744990

是的，修改一下，标题．谢谢．

zz5151353

收藏學習

謝謝樓主提供分享 !!!

[em23][em23][em23]

[em24][em24][em24]

[em27][em27][em27]

shing32356

我的机器上试都是0.08秒

不过还是要谢谢你们

[此贴子已经被作者于2007-11-21 22:45:25编辑过]

oobird

这样写简单些：

Sub tiger744990()
  Dim dic As Object, rng, i%, k$
  Dim aa!
  aa = Timer
  Set dic = CreateObject("Scripting.Dictionary")
  rng = Range([a2], [g2].End(xlDown))
  For i = 1 To UBound(rng)
    k = rng(i, 2) & rng(i, 3)
    If Not dic.exists(k) Then
      dic(k) = Array(rng(i, 1), rng(i, 2), rng(i, 3), rng(i, 4), rng(i, 5), rng(i, 6), rng(i, 7))
    Else
      rng(i, 5) = rng(i, 5) + dic(k)(4): rng(i, 6) = rng(i, 6) + dic(k)(5): rng(i, 7) = rng(i, 7) + dic(k)(6)
      dic(k) = Array(rng(i, 1), rng(i, 2), rng(i, 3), rng(i, 4), rng(i, 5), rng(i, 6), rng(i, 7))
    End If
  Next
  Sheet2.[a1:g1] = Sheet1.[a1:g1].Value
  Sheet2.[a2].Resize(dic.Count, 7) = Application.Transpose(Application.Transpose(dic.items))
  Set dic = Nothing
  MsgBox "Total:= " & Format(Timer - aa, "0.000") & "s"
End Sub

彭希仁

针对楼主的那个再来一个

大致看了一下,典和数组之间是有矛盾的.可以这么说后面的数组根本就没有用上字典.即没有省时反而费时.

不信你算一下3W条记录的,1W不重复的,你这种方法就和死机差不多.

If Not dic.exists(arr(i, 2) & arr(i, 3)) Then

x=x+1

 dic.Add arr(i, 2) & arr(i, 3),x

end if

X是什么,是位置,可直接查找位置而不是用For j = 0 To dic.Count - 1

这样才能体现字典意思,代码我就不帮你改了,慢慢理解吧,这样对你有好处

当然除了字典之外还有好方法,就是先排序之后上下比较再求和,速度不一定比字典慢

[此贴子已经被作者于2007-11-21 23:38:19编辑过]