【VBA字典数组201301班】课前热身习题四

sliang28 · 发表于 2013-10-22 14:40

本帖最后由 sliang28 于 2013-10-30 09:17 编辑

经过前面三道题测试,本题目对你们来说也不算什么了{:3912:}

没有时间限制,做出来及格.当然时间快的就更优秀{:2312:}

回帖不提交答案的,扣光你的积分和金币,让你从幼儿园小班再开始{:2812:}

注意了:题目中第二大有些歧义,第二大的意思是指相当于large函数取第几大一样.

答案上传了,你们做完核对一下.

Sellby · 发表于 2013-10-22 16:28

本帖最后由 Sellby 于 2013-10-28 16:05 编辑

第二大

Sub sellby()
Dim arr, tempArr(), brr(1 To 3)
Dim d As New Dictionary
Dim i&, iCode$, iDate As Date, t
t = Timer
With ThisWorkbook.Sheets(1)
arr = .Range("a2:c" & Cells(Rows.Count, 1).End(3).Row)
For i = 2 To UBound(arr)
iCode = arr(i, 1)
iDate = arr(i, 2)
If Not d.Exists(iCode) Then
d.Add (iCode), Array(iDate, iDate, 1)
'建一个字典，key是第一列Code,item是一个数组（含最大日期，第二大日期，计数）
Else
tempArr = d(iCode) '将item赋给数组tempArr
tempArr(2) = tempArr(2) + 1 ' 计数+1
If iDate > tempArr(0) Then '当日期大于最大日期时
tempArr(1) = tempArr(0) ‘将最大日期赋给第二大日期
tempArr(0) = iDate '将日期赋给最大日期
ElseIf iDate > tempArr(1) Then ’当日期小于最大日期且大于第二大日期时
tempArr(1) = iDate ‘将日期赋给第二大日期
ElseIf iDate<tempArr(1) And tempArr(2)=2 Then
tempArr(1) = iDate ‘将日期赋给第二大日期
End If
d(iCode) = tempArr '将新的tempArr赋给字典的item
End If
Next i
brr(1) = arr(1, 1): brr(2) = arr(1, 2): brr(3) = arr(1, 3)
tempArr = Application.Transpose(d.Items)
.Range("e2:g" & Rows.Count).Clear
.Range("e2:g2") = brr
.Range("e3").Resize(d.Count) = Application.Transpose(d.Keys)
.Range("f3").Resize(d.Count) = Application.Transpose(Application.Index(tempArr, 2))
.Range("g3").Resize(d.Count) = Application.Transpose(Application.Index(tempArr, 3))
End With
Set d = Nothing
MsgBox Timer - t
End Sub

复制代码

wp8680 · 发表于 2013-10-22 17:04

Sub test()
Dim d1, d2, d3
Dim arr, brr, crr, k As Long
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
Set d3 = CreateObject("scripting.dictionary")
arr = Range("a3:c" & Range("a" & Cells.Rows.Count).End(xlUp).Row)
For k = 1 To UBound(arr)
If d1.Count = 0 Then d1(arr(k, 1)) = arr(k, 2) Else If arr(k, 2) > d1(arr(k, 1)) Then d1(arr(k, 1)) = arr(k, 2)
If d2.Exists(arr(k, 1)) = False Then d2(arr(k, 1)) = 9E+307 Else If Abs(d1(arr(k, 1)) - arr(k, 2)) < d2(arr(k, 1)) And d1(arr(k, 1)) <> arr(k, 2) Then d2(arr(k, 1)) = Abs(d1(arr(k, 1)) - arr(k, 2))
If d3.Count = 0 Then d3(arr(k, 1)) = 1 Else d3(arr(k, 1)) = d3(arr(k, 1)) + 1
Next k
Range("m3").Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(d1.keys)
brr = d1.items
crr = d2.items
For k = 1 To d1.Count
Range("n2").Offset(k, 0) = brr(k - 1) - crr(k - 1)
Next k
Range("o3").Resize(d1.Count, 1) = Application.WorksheetFunction.Transpose(d3.items)
End Sub

复制代码

xdragon · 发表于 2013-10-22 18:42

本帖最后由 xdragon 于 2013-10-23 23:41 编辑

Sub xdragon()
Dim arr, dic As Object, dic1 As Object, dic2 As Object, i As Long, r As Long, t
t = Timer
With Sheets("sheet1")
r = .Cells(Rows.Count, 1).End(3).Row
arr = .Range("A3:C" & r)
ReDim arr2(1 To UBound(arr))
Set dic = CreateObject("scripting.dictionary")
Set dic1 = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr)
If Not dic.exists(arr(i, 1)) Or Not dic2.exists(arr(i, 1)) Then
dic(arr(i, 1)) = dic(arr(i, 1)) + arr(i, 3)
If Not dic1.exists(arr(i, 1)) Then
dic1(arr(i, 1)) = arr(i, 2)
Else
If arr(i, 2) < dic1(arr(i, 1)) Then
dic2(arr(i, 1)) = dic1(arr(i, 1))
dic1(arr(i, 1)) = arr(i, 2)
Else
dic2(arr(i, 1)) = arr(i, 2)
End If
End If
Else
dic(arr(i, 1)) = dic(arr(i, 1)) + arr(i, 3)
If arr(i, 2) >= dic2(arr(i, 1)) Then
dic1(arr(i, 1)) = dic2(arr(i, 1))
dic2(arr(i, 1)) = arr(i, 2)
Else
If arr(i, 2) >= dic1(arr(i, 1)) Then dic1(arr(i, 1)) = arr(i, 2)
End If
End If
Next
.Range("E3:E" & dic.Count + 2) = Application.Transpose(dic.keys)
.Range("F3:F" & dic.Count + 2) = Application.Transpose(dic1.items)
.Range("G3:G" & dic.Count + 2) = Application.Transpose(dic.items)
End With
MsgBox Timer - t
End Sub

复制代码

hoogle · 发表于 2013-10-22 18:44

'前期绑定字典
Sub hoogle()
Dim t As Double
t = Timer
Dim arrData, i As Long, j As Long, arrRes(1 To 1000, 1 To 4), Temp As Integer
Dim d As New dictionary
With Sheets("Sheet1")
arrData = .Range("a3", .Cells(Rows.Count, 3).End(3))
For i = 1 To UBound(arrData)
If Not d.exists(arrData(i, 1)) Then
j = j + 1
d(arrData(i, 1)) = j
arrRes(j, 1) = arrData(i, 1)
arrRes(j, 3) = 1
arrRes(j, 4) = arrData(i, 2)
arrRes(j, 2) = arrData(i, 2)
Else
Temp = d(arrData(i, 1))
arrRes(Temp, 3) = arrRes(Temp, 3) + 1
If arrData(i, 2) > arrRes(Temp, 2) Then
If arrData(i, 2) > arrRes(Temp, 4) Then
arrRes(Temp, 2) = arrRes(Temp, 4)
arrRes(Temp, 4) = arrData(i, 2)
Else
arrRes(Temp, 2) = arrData(i, 2)
End If
End If
End If
Next
.Range("j3").Resize(10000, 3).ClearContents
.Range("j3").Resize(10000, 3) = arrRes
End With
Debug.Print Timer - t
End Sub

复制代码

w2001pf · 发表于 2013-10-23 00:13

本帖最后由 w2001pf 于 2013-10-28 17:11 编辑

Sub 汇总()
t = Timer
Application.ScreenUpdating = False
Dim d As New Dictionary
Dim d1 As New Dictionary
Dim d2 As New Dictionary
Dim d3 As New Dictionary
With Sheets("Sheet1")
      rowend = .Range("A" & Rows.Count).End(xlUp).Row
      arr = .Range("A3:C" & rowend)
End With
For i = 1 To UBound(arr)
      d(arr(i, 1)) = d(arr(i, 1)) + 1
      If Not d1.Exists(arr(i, 1)) Then
         d1(arr(i, 1)) = arr(i, 2)
      Else
         If d1(arr(i, 1)) < arr(i, 2) Then d1(arr(i, 1)) = arr(i, 2)
      End If
Next i
For i = 1 To UBound(arr)
      If Not d2.Exists(arr(i, 1)) Then
         d2(arr(i, 1)) = 1
      Else
         If d1(arr(i, 1)) <> arr(i, 2) Then d2(arr(i, 1)) = d2(arr(i, 1)) + 1
      End If
Next i
For i = 1 To UBound(arr)
      If d2(arr(i, 1)) = 1 Then
         arr(i, 2) = arr(i, 2)
      Else
         If arr(i, 2) = d1(arr(i, 1)) Then arr(i, 2) = 0
      End If
Next i
For i = 1 To UBound(arr)
      If d3(arr(i, 1)) < arr(i, 2) Then d3(arr(i, 1)) = arr(i, 2)
Next i
ReDim arr1(1 To d.Count, 1 To 3)
   With Sheets("Sheet1")
      .Range("J3").Resize(d.Count, 3) = ""
      .Range("J3").Resize(d.Count) = Application.Transpose(d.Keys)
      .Range("K3").Resize(d.Count) = Application.Transpose(d3.Items)
      .Range("L3").Resize(d.Count) = Application.Transpose(d.Items)
End With

MsgBox Timer - t
Application.ScreenUpdating = True
End Sub

hrpotter · 发表于 2013-10-23 10:39

本帖最后由 hrpotter 于 2013-10-23 14:17 编辑

Sub test()
Dim arr, brr(1 To 10000, 1 To 2), temp(1 To 10000), d, t As Single
Dim i As Long, j As Long, k As Long
t = Timer
Set d = CreateObject("scripting.dictionary")
With Sheet1
arr = .Range("a1").CurrentRegion
For i = 3 To UBound(arr)
If d.exists(arr(i, 1)) Then
k = d(arr(i, 1))
brr(k, 2) = brr(k, 2) + 1
If arr(i, 2) <= temp(k) And arr(i, 2) > brr(k, 1) Then
brr(k, 1) = arr(i, 2)
ElseIf arr(i, 2) > temp(k) Then
brr(k, 1) = temp(k)
temp(k) = arr(i, 2)
End If
Else
j = j + 1
d(arr(i, 1)) = j
brr(j, 2) = 1
temp(j) = arr(i, 2)
End If
Next
For i = 1 To j
If brr(i, 1) = "" Then
brr(i, 1) = temp(i)
End If
Next
.Range("j3").Resize(j, 3).ClearContents
.Range("j3").Resize(j, 1) = Application.Transpose(d.keys)
.Range("k3").Resize(j, 2) = brr
End With
MsgBox Timer - t
End Sub

复制代码

fffox · 发表于 2013-10-23 12:09

本帖最后由 fffox 于 2013-10-23 20:25 编辑

自己的破电脑上运行时间是0.8秒
改了，这结果应该可以了吧

Sub hz() '采用校长的下棋法
Dim t, d
Dim arr, brr(1 To 1000, 1 To 3), crr(1 To 1000) As Date '定义arr为数据源数组，brr为结果数组，crr为最大值数组
Dim i As Long, k As Long, rs As Long
t = Timer
Set d = CreateObject("scripting.dictionary")
Application.DisplayAlerts = False
With Sheets("sheet1")
arr = .Range("a3:c" & .Cells(Rows.Count, 3).End(xlUp).Row)
For i = 1 To UBound(arr)
If d.exists(arr(i, 1)) Then
rs = d(arr(i, 1)) '结果数组中的行数
brr(rs, 3) = brr(rs, 3) + arr(i, 3) 'Qty.值增加
If brr(rs, 3) = 2 Then
If crr(rs) < arr(i, 2) Then
crr(rs) = arr(i, 2)
Else
brr(rs, 2) = arr(i, 2)
End If
ElseIf crr(rs) < arr(i, 2) Then
brr(rs, 2) = crr(rs)
crr(rs) = arr(i, 2)
ElseIf crr(rs) >= arr(i, 2) And brr(rs, 2) <= arr(i, 2) Then
brr(rs, 2) = arr(i, 2)
End If
Else '对应Code在结果数组中不存在时
k = k + 1
d(arr(i, 1)) = k
brr(k, 1) = arr(i, 1): brr(k, 2) = arr(i, 2)
brr(k, 3) = arr(i, 3): crr(k) = arr(i, 2)
End If
Next
.Range("j3").Resize(k, 3).ClearContents '清空目标区域
.Range("j3").Resize(k, 3) = brr '写入目标区域
End With
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub

复制代码

CheryBTL · 发表于 2013-10-23 12:47

本帖最后由 CheryBTL 于 2013-10-25 15:04 编辑

时间还早，来网吧改的，请学委确认是否正确：

Sub CheryBTL()
Dim i As Long, j As Integer, t As Single
Dim ar, re1(1 To 1000, 1 To 1) As Integer, re2(1 To 1000, 1 To 2), temp
Dim d As Object
t = Timer
ar = Sheets(1).Range("A1").CurrentRegion
Set d = CreateObject("Scripting.Dictionary")
For i = 3 To UBound(ar)
If Not d.exists(ar(i, 1)) Then
m = m + 1
d(ar(i, 1)) = m
re1(m, 1) = 1
re2(m, 1) = ar(i, 2)
Else
n = d(ar(i, 1))
re1(n, 1) = re1(n, 1) + 1
If ar(i, 2) >= re2(n, 1) Then
temp = re2(n, 1)
re2(n, 1) = ar(i, 2)
re2(n, 2) = temp
ElseIf ar(i, 2) >= re2(n, 2) Then
re2(n, 2) = ar(i, 2)
End If
End If
Next i
For i = 1 To d.Count
If re2(i, 2) = "" Then re2(i, 2) = re2(i, 1)
Next i
With Sheets(1)
.Range("J3").Resize(d.Count, 3).ClearContents
.Range("J3").Resize(d.Count) = Application.Transpose(d.keys)
.Range("k3").Resize(d.Count) = Application.Index(re2, 0, 2)
.Range("L3").Resize(d.Count) = re1
End With
MsgBox Timer - t
End Sub

复制代码

缔造者 · 发表于 2013-10-24 18:22

本帖最后由缔造者于 2013-10-27 15:58 编辑

给出的效果结果中个别第二大值貌似有误，请核查！
提取第二大值没想出好法，经向“山菊花”版主请教，套用了他的程序，结果第二大值还是有误，暂提交。
经“yangyangzhifeng”高手的再次修改，基本正确。
“yangyangzhifeng”的代码：

Sub test()
Dim d As Object, ds As Object
Dim i&, ar, t, br(), r
Set d = CreateObject("scripting.dictionary")
Set ds = CreateObject("scripting.dictionary")
ar = Sheet1.Range("a1").CurrentRegion
ReDim br(1 To UBound(ar), 1 To 3)
For i = 3 To UBound(ar)
r = d(Trim(ar(i, 1)))
If r = "" Then
r = d.Count: d(Trim(ar(i, 1))) = r
br(r, 1) = ar(i, 1)
br(r, 2) = ar(i, 2)
ds(Trim(ar(i, 1))) = ar(i, 3)
Else
ds(Trim(ar(i, 1))) = ds(Trim(ar(i, 1))) + ar(i, 3)
If br(r, 3) = "" Then
br(r, 3) = ar(i, 2)
If br(r, 2) > br(r, 3) Then
t = br(r, 2): br(r, 2) = br(r, 3): br(r, 3) = t
End If
Else
If ar(i, 2) > br(r, 3) Then
br(r, 2) = br(r, 3): br(r, 3) = ar(i, 2)
ElseIf ar(i, 2) > br(r, 2) Then
br(r, 2) = ar(i, 2)
End If
End If
End If
Next
Range("n2").Resize(UBound(ar), 3).ClearContents
Range("n2:p2") = Array("Code", "Date", "Qty.")
[n3].Resize(d.Count, 2) = br
[p3].Resize(ds.Count, 1) = Application.Transpose(ds.items)
Set d = Nothing
Set ds = Nothing
End Sub

复制代码

“山菊花”版主的代码（修改后的正确代码）：

Sub tiqu()
Dim ds As Object, d As Object
Dim nRow&, i&, n&, m&, Arr(), Brr()
Set ds = CreateObject("scripting.dictionary") '定义字典
Set d = CreateObject("scripting.dictionary")
nRow = Range("a1").CurrentRegion.Rows.Count
Arr = Range("a3:c" & nRow).Value
ReDim Brr(1 To nRow, 1 To 3)
For i = 1 To nRow - 2
n = ds(Arr(i, 1))
If n = 0 Then
m = m + 1
n = m
ds(Arr(i, 1)) = m
d(Arr(i, 1)) = Arr(i, 3)
Brr(m, 1) = Arr(i, 1)
Else
d(Arr(i, 1)) = d(Arr(i, 1)) + Arr(i, 3)
End If
If Arr(i, 2) >= Brr(n, 3) Then
Brr(n, 2) = Brr(n, 3)
Brr(n, 3) = Arr(i, 2)
ElseIf Arr(i, 2) > Brr(n, 2) Then
Brr(n, 2) = Arr(i, 2)
End If
Next
For i = 1 To m
If Brr(i, 2) = "" Then Brr(i, 2) = Brr(i, 3)
Next
Range("q2:s2") = Array("Code", "Date", "Qty.")
Range("q3:r" & nRow).Value = Brr
Range("s3").Resize(d.Count, 1).Value = Application.Transpose(d.items)
Set d = Nothing
Set ds = Nothing
End Sub

复制代码

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

[习题] 【VBA字典数组201301班】课前热身习题四

点评

评分

点评

点评

评分

点评

点评

点评

评分

点评

评分

点评

评分

点评

评分