作业参考代码

wcymiss · 发表于 2012-1-12 19:01

作业三_选做：

Sub 作业三_选做()
Dim d1 As Object, d2 As Object
Dim arr, brr, bhrr(), slrr(), crr(), drr() As Long
Dim i As Long, j As Long, s As String, n As Long, m As String
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
With Sheets("选做")
arr = .Range("a2:d" & .Cells(Rows.Count, 1).End(3).Row) '数据表
brr = .Range("h1").CurrentRegion '对照表
ReDim bhrr(1 To UBound(brr), 1 To UBound(brr, 2))
ReDim slrr(1 To UBound(brr), UBound(brr, 2))
ReDim crr(1 To UBound(arr), 1 To 1) '结果数组
For i = 2 To UBound(brr)
s = brr(i, 1) & "," & brr(i, 2)
d1(s) = i 'key为产品型号,item为对照表型号产地所在行号
For j = 3 To UBound(brr, 2) Step 2
If Len(brr(i, j)) > 0 Then
bhrr(i, j \ 2) = brr(i, j) '编号数组，i为对照表型号产地所在行号
slrr(i, j \ 2) = slrr(i, j \ 2 - 1) + brr(i, j + 1) '数量数组，与编号数组对应
End If
Next
Next
ReDim drr(2 To d1.Count + 1) '记录结果数组的编号已经取到对照表的第几个位置
For i = 2 To UBound(drr) '初始化
drr(i) = 1
Next
For i = 1 To UBound(arr)
s = arr(i, 2) & "," & arr(i, 3)
If d1.exists(s) Then '如果对照表有此型号产地，则：
n = d1(s) '取出item，因为后面要多次调用，所以将其赋值给变量
d2(s) = d2(s) + arr(i, 4)
For j = drr(n) To UBound(slrr, 2) '从drr(n)开始循环，减少循环量
If IsEmpty(slrr(n, j + 1)) Then Exit For
If d2(s) < slrr(n, j) Then Exit For
drr(n) = drr(n) + 1
Next
crr(i, 1) = bhrr(n, drr(n))
Else
m = m & vbCr & s
End If
Next
.Range("e2").Resize(Rows.Count - 1, 1).ClearContents
.Range("e2").Resize(UBound(crr), 1) = crr
End With
Set d1 = Nothing
Set d2 = Nothing
If Len(m) > 0 Then MsgBox "下列型号产地未找到：" & m
End Sub

复制代码

wcymiss · 发表于 2012-1-12 19:05

本帖最后由 wcymiss 于 2012-1-12 22:30 编辑

作业三_附加题：

Private Sub Worksheet_Change(ByVal Target As Range)
'作业三_附加题
'数据源里“俗称”需无重复,日期需从小到大排列
If Target.Count > 1 Then Exit Sub
If Target.Address = "$B$2" Or Target.Address = "$E$2" Then
Application.EnableEvents = False
Dim rn As String, mo As Long, a As Range
Dim arr, brr(1 To 8, 1 To 3), yue(1 To 2)
Dim i As Long, rw As Long, n As Long, bls As Long, jcs As Long
rn = Range("b2").Value
mo = Range("e2").Value
With Sheets("附加1")
arr = .Range("a3").CurrentRegion
Set a = .Range("a:a").Find(rn, .Range("a1")) '先查找到俗称
End With
If a Is Nothing Then
GoTo 100
Else
rw = a.Row - 2
End If
For j = 5 To UBound(arr, 2)
If IsEmpty(yue(1)) Then
If Month(arr(1, j)) = mo Then yue(1) = j
Else
If Month(arr(1, j)) <> mo Then
yue(2) = j - 1
Exit For
End If
End If
Next
For i = rw To UBound(arr)
If Len(arr(i, 2)) = 0 Then Exit For
n = n + 1
If n < 8 Then
brr(n, 1) = arr(i, 3)
brr(n, 2) = arr(i, 4)
For j = yue(1) To yue(2)
brr(n, 3) = brr(n, 3) + arr(i, j)
Next
bls = bls + brr(n, 3)
Else
For j = yue(1) To yue(2)
brr(8, 3) = brr(8, 3) + arr(i, j)
Next
End If
Next
bls = bls + brr(8, 3)
If n > 7 Then brr(8, 1) = "其他"
For j = yue(1) To yue(2)
jcs = jcs + arr(i, j)
Next
Range("b5") = jcs
Range("e5") = bls
Range("b8:d15") = brr
Set a = Nothing
100
Application.EnableEvents = True
End If
End Sub

复制代码

zm0115 · 发表于 2012-1-12 22:44

晕，字典字典字典，数组数组数组

liuguansky · 发表于 2012-1-13 08:59

吴姐辛苦了。。{:211:}

windimi007 · 发表于 2012-1-13 09:29

吴姐辛苦了，春节放假慢慢研究！{:1612:}

lzclzch · 发表于 2012-6-30 20:00

学习中谢谢

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

[习题] 作业参考代码

评分

评分