[字典与数组二期1班] 第3讲作业上交帖

wcymiss · 发表于 2011-12-31 08:50

本帖最后由 wcymiss 于 2012-1-4 20:44 编辑

为方便测试代码，请大家按照以下过程名命名规则：

sub 必做一_wcymiss
代码
end sub

复制代码

谢谢

附加题的结果模拟中的检查数据有误
数据源中的检查行数据，是模拟的，请不要直接用公式引用。需引用数据源中的数据、。

liuts · 发表于 2011-12-31 09:40

Sub 必做一_效果一_liuts()
Dim t
t = Timer
With Sheets("必做一")
Dim brr(1 To 10000, 1 To 50)
Dim arr, 行标%, 列标 As Byte, 步长 As Byte, i%, dic As New Dictionary, arr1, k%, imax%
arr1 = [{"仓库名称","序号","商品代码","数量",""}]
arr = .Range("a1:e" & Range("a65536").End(xlUp).Row)
For i = 2 To UBound(arr)
If Not dic.Exists(arr(i, 1)) Then
行标 = (dic.Count) * 5 + 1: dic(arr(i, 1)) = 1: 列标 = 0
For k = 1 To 5
brr(行标, k) = arr1(k)
brr(行标 + 1, 列标 + k) = arr(i, k)
Next
Else
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
列标 = (dic(arr(i, 1)) \ 5) * 5: 步长 = (dic(arr(i, 1)) - 1) Mod 4 + 1
If imax < 列标 Then imax = 列标
For k = 1 To 5
brr(行标 + 步长, 列标 + k) = arr(i, k)
Next
End If
Next
.Range("g2").Resize(dic.Count * 5, imax) = brr
End With
MsgBox Timer - t
End Sub
Sub 必做一_效果二_liuts()
Dim t
t = Timer
With Sheets("必做一")
Dim brr(1 To 10000, 1 To 100)
Dim arr, 行标%, 列标 As Byte, 步长 As Byte, 间隔 As Byte, 跨距 As Byte, 个数%, i%, dic As New Dictionary, d As New Dictionary, k%, x%, m%
arr1 = [{"仓库名称","序号","商品代码","数量",""}]
arr = .Range("a1:e" & .Range("a65536").End(xlUp).Row)
For i = 2 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + 1
Next
For i = 2 To UBound(arr)
个数 = d(arr(i, 1))
If Not dic.Exists(arr(i, 1)) Then
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
行标 = dic(arr(i, 1)) + 间隔: 列标 = 0
For k = 1 To 5
brr(行标, k) = arr1(k)
brr(行标 + 1, 列标 + k) = arr(i, k)
Next
间隔 = 间隔 + IIf(个数 < 15, 5, 个数 / 3 + 1)
跨距 = IIf(个数 < 15, 5, 个数 / 3 + 1)
Else
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
列标 = (dic(arr(i, 1)) \ 跨距) * 5: 步长 = dic(arr(i, 1)) Mod 跨距
For k = 1 To 5
brr(行标 + 步长, 列标 + k) = arr(i, k)
Next
End If
Next
.Range("g25").Resize(UBound(brr), 15) = brr
End With
MsgBox Timer - t
End Sub
Sub 必做二_liuts()
Dim t
t = Timer
Dim sh As Worksheet, brr, i%, arr, dic As New Dictionary, sr$, k As Byte, crr(1 To 10000, 1 To 256), n As Integer
For Each sh In Worksheets
If sh.Name Like "必二#" Then
arr = sh.UsedRange.Offset(1, 0)
For i = 1 To UBound(arr) - 1
For j = 1 To UBound(arr, 2)
crr(i + x, j) = arr(i, j)
Next
If Not dic.Exists(arr(i, 5)) Then
k = k + 1
dic(arr(i, 5)) = k
End If
Next
x = UBound(arr) - 1
n = x + n
End If
Next
With Sheets("必做二")
.Columns("c:z").ClearContents
.Range("c1").Resize(1, dic.Count) = dic.Keys
brr = .Range("a1").CurrentRegion
For i = 1 To UBound(brr)
dic(brr(i, 1) & brr(i, 2)) = i
Next
For i = 1 To n
brr(dic(crr(i, 1) & crr(i, 2)), dic(crr(i, 5)) + 2) = crr(i, 4) + brr(dic(crr(i, 1) & crr(i, 2)), dic(crr(i, 5)) + 2)
Next
.Range("a1").Resize(UBound(brr), UBound(brr, 2)) = brr
End With
MsgBox Timer - t
End Sub
Sub 选做_liuts()
Dim t
t = Timer
On Error GoTo err1
Dim arr, brr, i As Integer, j As Integer, dic As New Dictionary, x As Double, sr As String, 合计 As Double, d As New Dictionary
With Sheets("选做")
arr = .Range("a1:e" & .Range("a65536").End(xlUp).Row).CurrentRegion
brr = .Range("h1").CurrentRegion
For j = 2 To UBound(brr)
d(brr(j, 1) & brr(j, 2)) = Split(Split(Join(Application.Index(brr, j, 0), ","), ",", 3)(2), ",")
Next
For i = 2 To UBound(arr)
sr = arr(i, 2) & arr(i, 3)
dic(sr) = dic(sr) + arr(i, 4): 合计 = dic(sr): temp = 0: k = 1
Do
If Not d.Exists(sr) Then GoTo err1
temp = temp + Val(d(sr)(k))
Select Case 合计
Case Is <= temp
arr(i, 5) = d(sr)(k - 1)
Exit Do
End Select
k = k + 2
Loop Until d(sr)(k) = ""
If 合计 > temp Then arr(i, 5) = d(sr)(k - 3)
10: Next
.Range("a1:e" & UBound(arr)) = arr
If s <> "" Then MsgBox s & "————" & Chr(13) & "以上不存在！"
End With
MsgBox Timer - t
Exit Sub
err1:
s = sr & Chr(13) & s: GoTo 10
End Sub
Sub 附加_liuts()
On Error Resume Next
Application.EnableEvents = False
Dim 一列$, 四列$, m%, 结果(1 To 100, 1 To 3), tp(1 To 8, 1 To 3)
If Target.Address(0, 0) = "B2" Or Target.Address(0, 0) = "E2" Then
一列 = [b2]: 四列 = "2010" & [e2]
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim arr, dic As New Dictionary, i As Integer, j As Integer, k As Integer, brr(1 To 10000, 1 To 5), crr
Dim rg As Range, sr$
With Sheets("附加1")
If IsNull(.Columns("A:A").MergeCells) Then
Set rg = .Columns("A:A").SpecialCells(xlCellTypeConstants, 23).SpecialCells(xlCellTypeBlanks)
With rg
.MergeCells = False
.Offset(1, 0).FormulaR1C1 = "=R[-1]C"
End With
End If
arr = .Range("a3").CurrentRegion
For i = 2 To UBound(arr)
For j = 5 To UBound(arr, 2)
sr = arr(i, 1) & "," & arr(i, 3) & "," & arr(i, 4) & "," & Year(arr(1, j)) & Month(arr(1, j))
If Not dic.Exists(sr) And arr(i, 3) <> "" Then
k = k + 1
dic(sr) = Val(arr(i, j))
ElseIf arr(i, 3) <> "" Then
dic(sr) = dic(sr) + Val(arr(i, j))
End If
Next
Next
For i = 1 To dic.Count
crr = Split(dic.Keys(i - 1), ","): temp = dic.Items(i - 1)
brr(i, 1) = crr(0)
brr(i, 2) = crr(1)
brr(i, 3) = crr(2)
brr(i, 4) = crr(3)
brr(i, 5) = temp
Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For m = 1 To k
If brr(m, 1) = 一列 And brr(m, 4) = 四列 Then
icount = icount + 1
结果(icount, 1) = brr(m, 2)
结果(icount, 2) = brr(m, 3)
结果(icount, 3) = brr(m, 5)
End If
Next
总不良数 = Application.Sum(Application.Index(结果, , 3))
For m = 1 To UBound(结果)
If 结果(m, 1) = "其他" Or 结果(m, 1) = "其它" Then
tp(8, 1) = 结果(m, 1)
tp(8, 2) = 结果(m, 2)
tp(8, 3) = 结果(m, 3)
结果(m, 3) = 0
Exit For
End If
Next
For m = 1 To UBound(结果)
If 结果(m, 3) = Application.Max(Application.Index(结果, , 3)) Then
y = y + 1
If y > 7 Then Exit For
tp(y, 1) = 结果(m, 1)
tp(y, 2) = 结果(m, 2)
tp(y, 3) = 结果(m, 3)
结果(m, 3) = 0
End If
Next
其他数 = 总不良数 - (Application.Sum(Application.Index(tp, , 3)) - Application.Sum(Application.Index(tp, 8, 3)))
tp(8, 3) = 其他数
Sheets("附加题").Range("b8").Resize(8, 3) = tp
Sheets("附加题").Range("e5") = Application.Sum(Sheets("附加题").Range("d8:d15"))
Sheets("附加题").Range("b5") = Sheets("附加题").Range("e5") * 4
Application.DisplayAlerts = False
If rg Is Nothing Then GoTo 100
rg.MergeCells = True
Application.DisplayAlerts = True
End With
End If
100:
Application.EnableEvents = True
End Sub

复制代码

用了不少土办法，有时间再改用高效的方法：）
附加题数组排序还不太理解，用了土法检查数与不良数的关系没看太懂简单地做成了*4关系。

9lee · 发表于 2011-12-31 17:06

Sub 必做一的效果一_9lee()
Dim d As New Dictionary
Dim arr, dkey, ditem, brr(), crr, drr()
Dim i, j, m, n, a, b
With Sheets("必做一")
arr = .Range("a1").CurrentRegion
crr = .[a1:d1]
.Range("g:ab").ClearContents
For i = 2 To UBound(arr, 1)
d(arr(i, 1)) = d(arr(i, 1)) + 1
Next i
ditem = d.Items
dkey = d.Keys
For m = 0 To d.Count - 1 '按仓库名称循环，获得某仓库的数据
ReDim brr(1 To ditem(m), 1 To 4)
For i = 2 To UBound(arr)
If arr(i, 1) = dkey(m) Then
n = n + 1
brr(n, 1) = arr(i, 1)
brr(n, 2) = arr(i, 2)
brr(n, 3) = arr(i, 3)
brr(n, 4) = arr(i, 4)
End If
Next i
n = 0
'===按效果一将数据分成（4行5列）*几大列
a = (ditem(m) \ 4 + IIf(ditem(m) Mod 4, 1, 0)) * 5 '大列数
ReDim drr(1 To 4, 1 To a)
For j = 1 To a Step 5
For i = 1 To 4
b = i + j - (j + 5) \ 5
If b > ditem(m) Then Exit For
drr(i, j) = brr(b, 1)
drr(i, j + 1) = brr(b, 2)
drr(i, j + 2) = brr(b, 3)
drr(i, j + 3) = brr(b, 4)
Next i
Next j
'======将分好的数据赋给工作表
irow = irow + 1
.Cells(irow, "g").Resize(1, 4) = crr
.Cells(irow + 1, "g").Resize(4, UBound(drr, 2)) = drr
irow = irow + 4
Next m
'Stop
End With
Set d = Nothing
End Sub
Sub 必做一的效果二_9lee()
Dim d As New Dictionary
Dim arr, dkey, ditem, brr(), crr, drr()
Dim i, j, m, n, a, b
With Sheets("必做一")
arr = .Range("a1").CurrentRegion
crr = .[a1:d1]
.Range("g:cb").ClearContents
For i = 2 To UBound(arr, 1)
d(arr(i, 1)) = d(arr(i, 1)) + 1
Next i
ditem = d.Items
dkey = d.Keys
For m = 0 To d.Count - 1 '按仓库名称循环，获得某仓库的数据
ReDim brr(0 To ditem(m), 1 To 4)
brr(0, 1) = arr(1, 1)
brr(0, 2) = arr(1, 2)
brr(0, 3) = arr(1, 3)
For i = 2 To UBound(arr)
If arr(i, 1) = dkey(m) Then
n = n + 1
brr(n, 1) = arr(i, 1)
brr(n, 2) = arr(i, 2)
brr(n, 3) = arr(i, 3)
brr(n, 4) = arr(i, 4)
End If
Next i
n = 0
'===按效果二将数据分成（5至多行*15列）
If ditem(m) + 1 > 10 Then '确定行数
a = (ditem(m) + 1) \ 3 + IIf((ditem(m) + 1) Mod 3, 1, 0)
Else
a = 5
End If
ReDim drr(1 To a, 1 To 15)
b = -1
For j = 1 To 15 Step 5
For i = 1 To a
b = b + 1
If b > ditem(m) Then Exit For
drr(i, j) = brr(b, 1)
drr(i, j + 1) = brr(b, 2)
drr(i, j + 2) = brr(b, 3)
drr(i, j + 3) = brr(b, 4)
Next i
Next j
'======将分好的数据赋给工作表
.Cells(irow + 1, "g").Resize(UBound(drr), UBound(drr, 2)) = drr
irow = irow + UBound(drr)
Next m
'Stop
End With
Set d = Nothing
End Sub

复制代码

Sub 必做二9lee()
Dim d As New Dictionary
Dim arr, i, sh, brr(), k
For Each sh In Array(Sheets("必二1"), Sheets("必二2"))
arr = sh.Range("a1").CurrentRegion
For i = 2 To UBound(arr)
If Not d.Exists(arr(i, 5)) Then
k = k + 1
d(arr(i, 5)) = k
ReDim Preserve brr(1 To 12, 1 To k)
End If
brr(arr(i, 2), d(arr(i, 5))) = brr(arr(i, 2), d(arr(i, 5))) + arr(i, 4)
Next i
Next
With Sheets("必做二")
.Range("c:ab").ClearContents
.[c1].Resize(1, d.Count) = d.Keys
.[c2].Resize(12, UBound(brr, 2)) = brr
End With
Set d = Nothing
End Sub

复制代码

Sub 选做题_9lee()
Dim arr, brr, crr()
Dim d As New Dictionary, dd As New Dictionary
Dim s$, x$
With Sheets("选做")
arr = .Range("b2:d" & .[b65536].End(3).Row)
brr = .[h1].CurrentRegion
ReDim crr(1 To UBound(arr), 1 To 1)
For i = 2 To UBound(brr)
d(brr(i, 1) & vbTab & brr(i, 2)) = i
dd(brr(i, 1) & vbTab & brr(i, 2)) = 0
For j = 6 To UBound(brr, 2) Step 2
If Not IsEmpty(brr(i, j)) Then brr(i, j) = brr(i, j) + brr(i, j - 2)
Next j
Next i
For i = 1 To UBound(arr)
s = arr(i, 1) & vbTab & arr(i, 2)
If Not d.Exists(s) Then
x = x & Chr(10) & s
Else
dd(s) = dd(s) + arr(i, 3)
For j = 4 To UBound(brr, 2) Step 2
If IsEmpty(brr(d(s), j)) Then crr(i, 1) = brr(d(s), j - 3): Exit For
If dd(s) <= brr(d(s), j) Then crr(i, 1) = brr(d(s), j - 1): Exit For
Next j
End If
Next i
.[e2].Resize(UBound(crr)) = crr
End With
If IsEmpty(x) Then MsgBox "以下型号产地在编码表中不存在：" & Chr(10) & vbTab & x
Set d = Nothing
Set dd = Nothing
End Sub

复制代码

Sub 附加题_9lee()
Dim arr, brr(), crr
Dim d As New Dictionary
Dim iMonth, iName$, iSum%, jSum%, kSum%
Dim i%, j%, m%, sRow%, eRow%
With Sheets("附加题")
iMonth = .[e2]
iName = .[b2]
.[b5] = ""
.[e5] = ""
.Range("b8:e15").ClearContents
End With
With Sheets("附加1")
arr = .[a4].CurrentRegion
sRow = Application.Match(iName, Application.Index(arr, , 1), 0)
ReDim brr(1 To UBound(arr), 1 To 3)
For i = sRow To UBound(arr)
If arr(i, 4) = "检查数" Then '总检查数
For j = 5 To UBound(arr, 2)
If Month(arr(1, j)) > iMonth Then Exit For
If Month(arr(1, j)) = iMonth And Not IsEmpty(arr(i, j)) Then iSum = iSum + arr(i, j)
Next j
Exit For
End If
For j = 5 To UBound(arr, 2)
If Month(arr(1, j)) > iMonth Then Exit For
If Month(arr(1, j)) = iMonth And Not IsEmpty(arr(i, j)) Then
If arr(i, 3) = "其它" Then kSum = kSum + arr(i, j): Exit For '不良内容为其它的总数
If Not d.Exists(arr(i, 3)) Then m = m + 1: d(arr(i, 3)) = ""
brr(m, 1) = arr(i, 3)
brr(m, 2) = arr(i, 4)
brr(m, 3) = brr(m, 3) + arr(i, j)
jSum = jSum + brr(m, 3) '不良数合计
End If
Next j
Next i
End With
If m = 0 And kSum = 0 Then Exit Sub
'====排序
For i = 2 To m
temp1 = brr(i, 1): temp2 = brr(i, 2): temp3 = brr(i, 3)
For j = i - 1 To 1 Step -1
If brr(j, 3) >= temp3 Then Exit For
brr(j + 1, 1) = brr(j, 1): brr(j + 1, 2) = brr(j, 2): brr(j + 1, 3) = brr(j, 3)
Next j
brr(j + 1, 1) = temp1: brr(j + 1, 2) = temp2: brr(j + 1, 3) = temp3
Next i
'====
With Sheets("附加题")
.[b5] = iSum
.[e5] = jSum + kSum
.[b8].Resize(IIf(m > 7, 7, m), 3) = brr
If kSum > 0 Then .[b15] = "其它": [d15] = kSum
End With
Set d = Nothing
End Sub

复制代码

乐满地 · 发表于 2012-1-1 09:01

Sub 必做一1乐满地()
Dim d As New Dictionary
Dim arr, brr
Dim x&, y%, k&, m%, n%, o%
arr = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row)
arr1 = Range("a1:d1")
ReDim brr(1 To 1000, 1 To 255)
For x = 1 To UBound(arr)
If Not d.Exists(arr(x, 1)) Then
k = 1 + m * 5
d.Add (arr(x, 1)), ""
brr(k, 1) = arr1(1, 1): brr(k, 2) = arr1(1, 2): brr(k, 3) = arr1(1, 3): brr(k, 4) = arr1(1, 4)
brr(k + 1, 1) = arr(x, 1): brr(k + 1, 2) = arr(x, 2): brr(k + 1, 3) = arr(x, 3): brr(k + 1, 4) = arr(x, 4)
m = m + 1
n = 1: o = 0
Else
n = n + 1
For y = 1 To 4
brr(k + n, o * 5 + y) = arr(x, y)
Next y
If n = 4 Then o = o + 1: n = 0
End If
Next x
Range("f1").Resize(k + 4, 200).ClearContents
[f1].Resize(k + 4, 200) = brr
End Sub

复制代码

Sub 必做一2乐满地()
Dim d As New Dictionary
Dim arr, brr
Dim x&, y%, k&, m%, n%, o%
arr = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row)
arr1 = Range("a1:d1")
ReDim brr(1 To 1000, 1 To 14)
k = -4
For x = 1 To UBound(arr)
If Not d.Exists(arr(x, 1)) Then
k = k + 5
d.Add (arr(x, 1)), ""
For y = 1 To 4
brr(k, y) = arr1(1, y)
brr(k + 1, y) = arr(x, y)
Next y
m = m + 1
n = 1: o = 0
Else
If n = 4 Then
o = o + 1: n = 0
Else
n = n + 1
End If
If o = 3 Then k = k + 5: o = 0
For y = 1 To 4
brr(k + n, o * 5 + y) = arr(x, y)
Next y
End If
Next x
Range("f26").Resize(k + 4, 14).ClearContents
[f26].Resize(k + 4, 14) = brr
End Sub

复制代码

Sub 必做二乐满地()
Dim dr As New Dictionary
Dim dc As New Dictionary
Dim arrR, arr, brr(1 To 12, 1 To 12), brr1
Dim x%, y%
brr1 = Array("必二1", "必二2")
arrR = Range("a2:b13")
For x = 1 To UBound(arrR)
dr(arrR(x, 1) & "|" & arrR(x, 2)) = x
Next
For x = 0 To UBound(brr1)
With Sheets(brr1(x))
arr = .Range("a2:e" & .Range("a65536").End(3).Row)
End With
For y = 1 To UBound(arr)
If dc.Exists(arr(y, 5)) Then
brr(dr(arr(y, 1) & "|" & arr(y, 2)), dc(arr(y, 5))) = brr(dr(arr(y, 1) & "|" & arr(y, 2)), dc(arr(y, 5))) + arr(y, 4)
Else
k = k + 1
dc(arr(y, 5)) = k
brr(dr(arr(y, 1) & "|" & arr(y, 2)), dc(arr(y, 5))) = arr(y, 4)
End If
Next y
Erase arr
Next x
Range("c1").Resize(1, dc.Count).ClearContents
Range("c2").Resize(dr.Count, dc.Count).ClearContents
Range("c1").Resize(1, dc.Count) = dc.Keys
Range("c2").Resize(dr.Count, dc.Count) = brr
End Sub

复制代码

Sub 选做乐满地()
Dim arr1, arr2, brr, crr()
Dim x&, y%, c%, k%, dj&, temp
Dim d As New Dictionary
Dim d1 As New Dictionary
Dim dmsg As New Dictionary
arr1 = Range(Cells(2, 8), Cells([h65536].End(3).Row, Cells(1, 255).End(xlToLeft).Column + 2)) '+2留两个空列
arr2 = Range("a2:d" & [a65536].End(3).Row)
For x = 1 To UBound(arr1)
d.Add (arr1(x, 1) & "|" & arr1(x, 2)), 0
d1(arr1(x, 1) & "|" & arr1(x, 2)) = x
Next x
c = (Cells(1, 255).End(xlToLeft).Column - 9) / 2
ReDim brr(1 To UBound(arr2), 1 To 1)
For x = 1 To UBound(arr2)
If d.Exists(arr2(x, 2) & "|" & arr2(x, 3)) Then
d(arr2(x, 2) & "|" & arr2(x, 3)) = arr2(x, 4) + d(arr2(x, 2) & "|" & arr2(x, 3))
temp = 0
For y = 1 To c + 1
temp = temp + arr1(d1(arr2(x, 2) & "|" & arr2(x, 3)), y * 2 + 2)
If d(arr2(x, 2) & "|" & arr2(x, 3)) < temp Then
brr(x, 1) = arr1(d1(arr2(x, 2) & "|" & arr2(x, 3)), y * 2 + 1): Exit For
ElseIf arr1(d1(arr2(x, 2) & "|" & arr2(x, 3)), y * 2 + 2) = "" Then
brr(x, 1) = arr1(d1(arr2(x, 2) & "|" & arr2(x, 3)), y * 2 - 1): Exit For
End If
Next y
Else
k = k + 1
ReDim Preserve crr(1 To k)
crr(k) = arr2(x, 2) & "|" & arr2(x, 3)
End If
Next x
Range("e2").Resize(UBound(arr2)).ClearContents
Range("e2").Resize(UBound(arr2)) = brr
For x = 1 To UBound(crr)
If Not dmsg.Exists(crr(x)) Then dmsg.Add crr(x), ""
Next x
MsgBox "不存在型号产地有：" & VBA.Join(dmsg.Keys, ";")
End Sub

复制代码

Sub 附加题乐满地()
Dim arry
Dim sch As String, yuef%, sta%, en%, sta2%, en2%
Dim arr
Dim x, y
On Error GoTo 100
sch = [b2]: yuef = [e2]
With Sheets("附加1")
arry = .Range("a3:at" & .[d65536].End(3).Row)
End With
For x = 1 To UBound(arry)
If arry(x, 1) = sch Then
sta = x
Exit For
End If
Next
For x = sta To UBound(arry)
If arry(x, 2) = "" Then
en = x: Exit For
End If
Next x
For x = 5 To UBound(arry, 2)
If sta2 = 0 And Month(arry(1, x)) = yuef Then
sta2 = x: x = x + 1
End If
If sta2 > 0 And Month(arry(1, x)) <> yuef Then
en2 = x - 1: Exit For
End If
Next x
ReDim arr(1 To en - sta + 1, 1 To 3)
For x = sta To en
arr(x - sta + 1, 1) = arry(x, 3)
arr(x - sta + 1, 2) = arry(x, 4)
For y = sta2 To en2
arr(x - sta + 1, 3) = arr(x - sta + 1, 3) + arry(x, y)
Next y
Next x
Dim imin
Dim tmp
For x = UBound(arr) - 1 To 1 Step -1 '“其它”一般在后面，倒循环相对快点
If arr(x, 1) = "其它" Then '找到其它就与最后一行换位
For y = 1 To 3
tmp = arr(x, y)
arr(x, y) = arr(UBound(arr) - 1, y):
arr(UBound(arr) - 1, y) = tmp
Next y
Exit For
End If
Next
For x = UBound(arr) - 2 To 2 Step -1
imin = 1
For y = 1 To x
If arr(y, 3) < arr(imin, 3) Then imin = y
Next y
For y = 1 To 3
tmp = arr(x, y)
arr(x, y) = arr(imin, y):
arr(imin, y) = tmp
Next y
Next x
arr(8, 1) = "其它": arr(8, 2) = "": tmp = 0
For x = 8 To UBound(arr) - 1
tmp = tmp + arr(x, 3)
Next x
arr(8, 3) = tmp
tmp = 0
For x = 1 To 8
tmp = arr(x, 3) + tmp
Next x
For x = 1 To 8
If arr(x, 3) = "" Or arr(x, 3) = 0 Then
arr(x, 1) = ""
arr(x, 2) = ""
arr(x, 3) = ""
End If
Next x
Range("b8:d15").ClearContents
Range("b8:d15") = arr
[b5] = arr(UBound(arr), 3)
[e5] = tmp
Exit Sub
For x = 1 To 8
Next
100: MsgBox "月份选择有误"
End Sub

复制代码

sunjing-zxl · 发表于 2012-1-1 14:16

本帖最后由 sunjing-zxl 于 2012-1-2 10:09 编辑

Sub 必做1效果1_012_sunjing_zxl()
Dim d As New Dictionary, d1 As New Dictionary, d2 As New Dictionary
Dim arr, arr1()
Dim i As Long, j As Long, n As Long, m As Long
Range("F1:IV1000").ClearContents
Range("F1:IV1000").NumberFormatLocal = "@"
arr = Range("A1:D" & [A65536].End(xlUp).Row)
For i = 2 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + 1
Next i
n = WorksheetFunction.Large(d.Items(), 1)
m = d.Count
ReDim arr1(1 To m * 5, 1 To Abs(Int(-n / 4)) * 5)
For i = 2 To UBound(arr)
d1(arr(i, 1)) = d1(arr(i, 1)) + 1
m = 1 + (d1.Count - 1) * 5
For j = 1 To 4
arr1(m, j) = arr(1, j)
arr1(m + ((d1(arr(i, 1)) - 1) Mod 4) + 1, Int((d1(arr(i, 1)) - 1) / 4) * 5 + j) = arr(i, j)
Next j
Next i
Range("F1").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
End Sub

复制代码

Sub 必做1效果2_012_sunjing_zxl()
Dim d As New Dictionary, d1 As New Dictionary
Dim d2 As New Dictionary, d3 As New Dictionary
Dim arr, arr1()
Dim i As Long, j As Long, n As Long, m As Long
Range("F1:IV1000").ClearContents
Range("F1:IV1000").NumberFormatLocal = "@"
arr = Range("A1:D" & [A65536].End(xlUp).Row)
'统计每个仓库名的个数
For i = 2 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + 1
Next i
n = 1
m = 0
'统计每个仓库名所占行数(d2)
'统计每个仓库名起点行号(d3)
For i = 0 To d.Count - 1
d2(d.Keys(i)) = WorksheetFunction.max(WorksheetFunction.RoundUp((d.Items(i) + 1) / 3, 0), 5)
d3(d.Keys(i)) = n
m = d2(d.Keys(i))
n = n + m
Next i
ReDim arr1(1 To n - 1, 1 To 14)
For i = 2 To UBound(arr)
d1(arr(i, 1)) = d1(arr(i, 1)) + 1
If d1(arr(i, 1)) + 1 > 15 Then
m = d3(arr(i, 1)) + 5 '超出5行的起点行号
n = d2(arr(i, 1)) - 5 '增加的行数
m = (d1(arr(i, 1)) - 15) Mod n + m
n = Int((d1(arr(i, 1)) - 15) / n) * 5
For j = 1 To 4
arr1(m, n + j) = arr(i, j)
Next j
Else
m = d3(arr(i, 1)) + d1(arr(i, 1)) Mod 5
n = Int(d1(arr(i, 1)) / 5) * 5
For j = 1 To 4
arr1(d3(arr(i, 1)), j) = arr(1, j)
arr1(m, n + j) = arr(i, j)
Next j
End If
Next i
Range("F1").Resize(UBound(arr1), UBound(arr1, 2)) = arr1
End Sub

复制代码

Sub 必做2_012_sunjing_zxl()
Dim d As New Dictionary
Dim arr, arr1()
Dim i As Long, j As Long
Range(Range("C1"), Cells([IV65536].End(xlToLeft).Column, 13)).ClearContents
For i = 1 To Sheets.Count
If Left(Sheets(i).Name, 2) = "必二" Then
With Sheets(i)
arr = .Range("A2:E" & .[A65536].End(xlUp).Row)
End With
For j = 1 To UBound(arr)
If d.Exists(arr(j, 5)) Then
arr1(arr(j, 2) + 1, d(arr(j, 5))) = arr(j, 4) + arr1(arr(j, 2) + 1, d(arr(j, 5)))
Else
d(arr(j, 5)) = d.Count + 1
ReDim Preserve arr1(1 To 13, 1 To d.Count)
arr1(1, d(arr(j, 5))) = arr(j, 5)
arr1(arr(j, 2) + 1, d(arr(j, 5))) = arr(j, 4)
End If
Next j
End If
Next i
Range("C1").Resize(13, UBound(arr1, 2)) = arr1
End Sub

复制代码

Sub 选做题_012_sunjing_zxl()
Dim d1 As New Dictionary, d2 As New Dictionary
Dim arr1, arr2, arr
Dim i As Long, j As Long, n As Long, m As Long, k As Long
Dim str As String, L As Long
Range("E2:E" & [A65536].End(xlUp).Row).ClearContents
arr1 = Range("A2:D" & [A65536].End(xlUp).Row)
arr2 = Range(Range("H2"), Cells([H2].End(xlDown).Row, [H1].End(xlToRight).Column))
ReDim arr(1 To UBound(arr1), 1 To 1)
For i = 1 To UBound(arr2)
d2(arr2(i, 1) + arr2(i, 2)) = d2.Count + 1
Next i
For i = 1 To UBound(arr1)
d1(arr1(i, 2) + arr1(i, 3)) = d1(arr1(i, 2) + arr1(i, 3)) + arr1(i, 4)
n = d2(arr1(i, 2) + arr1(i, 3))
k = 0
For j = 4 To UBound(arr2, 2) Step 2
If n = 0 Then
arr(i, 1) = ""
str = str & "," & arr1(i, 2) + arr1(i, 3)
L = L + 1
Exit For
ElseIf arr2(n, j) = "" Then
m = j - 3
Exit For
Else
k = k + arr2(n, j)
If d1(arr1(i, 2) + arr1(i, 3)) < k Then
m = j - 1
Exit For
End If
End If
Next j
If n <> 0 Then
arr(i, 1) = arr2(n, m)
End If
Next i
Range("E2").Resize(UBound(arr), 1) = arr
If L = 0 Then
MsgBox "编码完成,没有不存的型号产地"
Else
MsgBox "编码完成,不存在型号产地的有" & str
End If
End Sub

复制代码

Sub 附加题_012_sunjing_zxl()
'Dim d1 As New Dictionary, d2 As New Dictionary
Dim arr1, arr2, arr3
Dim i As Long, j As Long, n As String, m As Long
Dim k1 As Long, k2 As Long, k3 As Long, k4 As Long
Dim 最大值 As Long, 计数 As Long, t1 As Double, t2 As Double
t1 = Timer
With Sheets("附加1")
n = Range("B2")
m = Range("E2")
arr1 = .Range("A1:A" & .[A65536].End(xlUp).Row)
arr2 = .Range(.[A3], .Cells(3, .[IV3].End(xlToLeft).Column))
For i = 1 To UBound(arr1)
If arr1(i, 1) = n Then
k1 = i
k2 = .Cells(i, 2).End(xlDown).Row
Exit For
End If
Next i
For j = 5 To UBound(arr2, 2)
If Month(arr2(1, j)) = m Then
k3 = j
For i = k3 To UBound(arr2, 2)
If i = UBound(arr2, 2) Then
k4 = i
ElseIf Month(arr2(1, i)) = m + 1 Then
k4 = i - 1
Exit For
End If
Next i
Exit For
End If
Next j
arr1 = .Range(.Cells(k1, k3), .Cells(k2, k4))
arr2 = .Range(.Cells(k1, 3), .Cells(k2, 4))
n = WorksheetFunction.Sum(arr1)
m = WorksheetFunction.Sum(.Range(.Cells(k2 + 1, k3), .Cells(k2 + 1, k4)))
ReDim arr3(UBound(arr1) - 1)
For i = 1 To UBound(arr1, 1)
arr3(i - 1) = Application.Sum(Application.Index(arr1, i, 0))
Next i
ReDim arr1(1 To 8, 1 To 3)
1:
最大值 = Application.WorksheetFunction.Large(arr3, 1)
For j = 0 To UBound(arr3)
If arr3(j) = 最大值 Then
If arr2(j + 1, 1) <> "其它" Then
计数 = 计数 + 1
arr1(计数, 1) = arr2(j + 1, 1)
arr1(计数, 2) = arr2(j + 1, 2)
arr1(计数, 3) = 最大值
arr3(j) = 0
Exit For
Else
arr1(8, 1) = "其它"
arr1(8, 3) = 最大值
arr3(j) = 0
Exit For
End If
End If
Next j
If 计数 < 7 Then
GoTo 1
End If
arr1(8, 1) = "其它"
arr1(8, 3) = arr1(8, 3) + WorksheetFunction.Sum(arr3)
End With
For i = 1 To 7
If arr1(i, 3) = 0 Then
For j = 1 To 3
arr1(i, j) = ""
Next j
End If
Next i
Range("B8").Resize(8, 3) = arr1
Range("B5") = m
Range("E5") = n
t2 = Timer
MsgBox "统计用时" & t2 - t1
End Sub

复制代码

windimi007 · 发表于 2012-1-2 19:08

吴姐辛苦了，我先把必做题交了吧！选做题和附加题如果有时间到时候再补上！{:1712:}

Sub 必做一效果一_windimi007()
Dim d As Object, dic As Object
Dim arr1, arr2(1 To 1000, 1 To 100)
Dim i&
Set d = CreateObject("scripting.dictionary")
Set dic = CreateObject("scripting.dictionary")
arr1 = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row)
For i = 1 To UBound(arr1)
If d.exists(arr1(i, 1)) Then
d(arr1(i, 1)) = d(arr1(i, 1)) + 1
arr2((d(arr1(i, 1)) - 1) Mod 4 + dic(arr1(i, 1)) * 5 - 3, ((d(arr1(i, 1)) - 1) \ 4) * 5 + 1) = arr1(i, 1)
arr2((d(arr1(i, 1)) - 1) Mod 4 + dic(arr1(i, 1)) * 5 - 3, ((d(arr1(i, 1)) - 1) \ 4) * 5 + 2) = arr1(i, 2)
arr2((d(arr1(i, 1)) - 1) Mod 4 + dic(arr1(i, 1)) * 5 - 3, ((d(arr1(i, 1)) - 1) \ 4) * 5 + 3) = "'" & arr1(i, 3)
arr2((d(arr1(i, 1)) - 1) Mod 4 + dic(arr1(i, 1)) * 5 - 3, ((d(arr1(i, 1)) - 1) \ 4) * 5 + 4) = arr1(i, 4)
Else
d(arr1(i, 1)) = 1
dic(arr1(i, 1)) = d.Count
arr2(d.Count * 5 - 4, 1) = "仓库名称": arr2(d.Count * 5 - 4, 2) = "序号": arr2(d.Count * 5 - 4, 3) = "商品代码": arr2(d.Count * 5 - 4, 4) = "数量"
arr2(d.Count * 5 - 3, 1) = arr1(i, 1): arr2(d.Count * 5 - 3, 2) = arr1(i, 2): arr2(d.Count * 5 - 3, 3) = arr1(i, 3): arr2(d.Count * 5 - 3, 4) = arr1(i, 4)
End If
Next i
Range("F3").Resize(d.Count * 5, 100) = arr2
End Sub

复制代码

Sub 必做一效果二_windimi007()
Dim dic As Object, d As Object
Dim arr1, arr2(1 To 1000, 1 To 14)
Dim i&, j&, k&
Dim x
Set dic = CreateObject("scripting.dictionary")
Set d = CreateObject("scripting.dictionary")
arr1 = Range("A2:D" & Cells(Rows.Count, 1).End(3).Row)
k = 1
For i = 1 To UBound(arr1)
dic(arr1(i, 1)) = dic(arr1(i, 1)) + 1
Next i
x = dic.items
Set dic = Nothing
For i = 1 To UBound(arr1)
If d.exists(arr1(i, 1)) Then
d(arr1(i, 1)) = d(arr1(i, 1)) + 1
arr2(d(arr1(i, 1)) Mod 5 + (d(arr1(i, 1)) \ 15) * 5 + k, ((d(arr1(i, 1)) \ 5) Mod 3) * 5 + 1) = arr1(i, 1)
arr2(d(arr1(i, 1)) Mod 5 + (d(arr1(i, 1)) \ 15) * 5 + k, ((d(arr1(i, 1)) \ 5) Mod 3) * 5 + 2) = arr1(i, 2)
arr2(d(arr1(i, 1)) Mod 5 + (d(arr1(i, 1)) \ 15) * 5 + k, ((d(arr1(i, 1)) \ 5) Mod 3) * 5 + 3) = "'" & arr1(i, 3)
arr2(d(arr1(i, 1)) Mod 5 + (d(arr1(i, 1)) \ 15) * 5 + k, ((d(arr1(i, 1)) \ 5) Mod 3) * 5 + 4) = arr1(i, 4)
Else
d(arr1(i, 1)) = 1
If d.Count > 1 Then k = k + (x(d.Count - 2) \ 15) * 5 + 5
arr2(k, 1) = "仓库名称": arr2(k, 2) = "序号": arr2(k, 3) = "商品代码": arr2(k, 4) = "数量"
arr2(k + 1, 1) = arr1(i, 1): arr2(k + 1, 2) = arr1(i, 2): arr2(k + 1, 3) = arr1(i, 3): arr2(k + 1, 4) = arr1(i, 4)
End If
Next i
Range("F26").Resize(1000, 14) = arr2
End Sub

复制代码

Sub 必做二_windimi007()
Dim d1 As Object, d2 As Object
Dim arr1, arr2()
Dim sh As Worksheet
Dim i&
Set d1 = CreateObject("scripting.dictionary")
Set d2 = CreateObject("scripting.dictionary")
arr1 = Range("A2:B13")
For i = 1 To UBound(arr1)
d1(arr1(i, 1) & vbTab & arr1(i, 2)) = i + 1
Next i
For Each sh In Worksheets(Array("必二1", "必二2"))
arr1 = sh.Range("A1").CurrentRegion
For i = 2 To UBound(arr1)
If d2.exists(arr1(i, 5)) Then
arr2(d1(arr1(i, 1) & vbTab & arr1(i, 2)), d2(arr1(i, 5))) = arr2(d1(arr1(i, 1) & vbTab & arr1(i, 2)), d2(arr1(i, 5))) + arr1(i, 4)
Else
d2(arr1(i, 5)) = d2.Count + 1
ReDim Preserve arr2(1 To 13, 1 To d2.Count)
arr2(1, d2.Count) = arr1(i, 5)
arr2(d1(arr1(i, 1) & vbTab & arr1(i, 2)), d2.Count) = arr1(i, 4)
End If
Next i
Next sh
Range("C1").Resize(13, d2.Count) = arr2
End Sub

复制代码

rxj_0414 · 发表于 2012-1-2 20:28

本帖最后由 rxj_0414 于 2012-1-2 20:30 编辑

'===================================================================================================
Sub 附加_by_rxj_0414()
Dim arr, Dbad As New Dictionary, Dabc As New Dictionary, i%, j%, k%, strName$, iMon%
Dim Cnt&, iCheck&, iBad&, iNo()
arr = Sheet7.Range("A3").CurrentRegion
For i = 1 To UBound(arr)
If Len(arr(i, 1)) > 0 And Len(arr(i, 2)) > 0 Then
strName = arr(i, 1)
Else
arr(i, 1) = strName
End If
Next i
strName = Sheet6.Range("B2").Value: iMon = Sheet6.Range("E2").Value
For i = 2 To UBound(arr)
Dabc(arr(i, 3)) = arr(i, 4)
If arr(i, 1) = strName Then
For j = 5 To UBound(arr, 2)
If Month(arr(1, j)) = iMon And arr(i, 4) <> "检查数" Then
Dbad(arr(i, 3)) = Dbad(arr(i, 3)) + arr(i, j)
iBad = iBad + arr(i, j)
End If
Next j
If arr(i, 4) = "检查数" Then
For k = 5 To UBound(arr, 2)
If Month(arr(1, k)) = iMon Then
iCheck = iCheck + arr(i, k)
End If
Next k
End If
End If
Next i
For i = Dbad.Count - 1 To 0 Step -1
If Dbad.Items(i) = 0 Then
Dbad.Remove (Dbad.Keys(i))
End If
Next i
If Dbad.Count > 7 Then
For i = Dbad.Count - 1 To 7 Step -1
Cnt = Cnt + Dbad.Items(i)
Dbad.Remove (Dbad.Keys(i))
Next i
Dbad.Add "其他", Cnt
End If
With Sheet6
.Range("B5") = iCheck
.Range("E5") = iBad
.Range("A8:D15").ClearContents
End With
If Dbad.Count > 0 Then
ReDim iNo(1 To Dbad.Count)
For i = 1 To Dbad.Count
iNo(i) = i
Next i
With Sheet6
.Range("A8").Resize(UBound(iNo), 1) = Application.Transpose(iNo)
.Range("B8").Resize(Dbad.Count, 1) = Application.Transpose(Dbad.Keys)
.Range("D8").Resize(Dbad.Count, 1) = Application.Transpose(Dbad.Items)
If Dbad.Count > 7 Then
.Range("C8").Resize(7, 1) = Application.Transpose(Dabc.Items)
Else
.Range("C8").Resize(Dbad.Count, 1) = Application.Transpose(Dabc.Items)
End If
End With
End If
End Sub
'===================================================================================================
Sub 选做_by_rxj_0414()
Dim D As New Dictionary, i%, arr, arr2, x%, j%, Cnt&, str$, Fd As Boolean
arr = Sheet5.Range("B2:E" & Sheet5.Cells(Sheet5.Rows.Count, 1).End(3).Row).Value
For i = 2 To 5
If Sheet5.Cells(i, "H").End(xlToRight).Column > x Then
x = Sheet5.Cells(i, "H").End(xlToRight).Column
End If
Next i
arr2 = Sheet5.Range(Range("H2"), Cells(5, x)).Value
For i = 1 To UBound(arr)
Fd = False
D(arr(i, 1) & arr(i, 2)) = D(arr(i, 1) & arr(i, 2)) + arr(i, 3)
For x = 1 To UBound(arr2, 1)
If arr2(x, 1) & arr2(x, 2) = arr(i, 1) & arr(i, 2) Then
Cnt = 0
For j = 4 To UBound(arr2, 2) Step 2
If Len(arr2(x, j)) > 0 Then
Cnt = Cnt + arr2(x, j)
If D(arr(i, 1) & arr(i, 2)) < Cnt Then
arr(i, 4) = arr2(x, j - 1)
Exit For
Else
arr(i, 4) = "11"
End If
Else
If arr(i, 4) = "11" Then
arr(i, 4) = arr2(x, j - 3)
End If
End If
Next j
Fd = True
Exit For
End If
Next x
If Fd = False Then
str = str & arr(i, 1) & " " & arr(i, 2) & vbCrLf
End If
Next i
Sheet5.Range("B2:B100").ClearContents
Sheet5.Range("B2").Resize(UBound(arr), UBound(arr, 2)) = arr
If Len(str) Then MsgBox "未找到:" & vbCrLf & str
End Sub
'===================================================================================================
Sub 必做二_by_rxj_0414()
Dim D As New Dictionary, Dmon As New Dictionary, ws(), i%, arr, arrRT(), iWs%
ws = Array("必二1", "必二2")
arr = Sheet2.Range("A2:B13").Value
For i = 1 To UBound(arr)
Dmon(arr(i, 1) & arr(i, 2)) = i
Next i
For iWs = LBound(ws) To UBound(ws)
With Sheets(ws(iWs))
arr = .Range("A2:E" & .Cells(.Rows.Count, 1).End(3).Row).Value
For i = 1 To UBound(arr)
If Not D.Exists(arr(i, 5)) Then
D(arr(i, 5)) = D.Count + 1
End If
ReDim Preserve arrRT(1 To Dmon.Count, 1 To D.Count)
arrRT(Dmon(arr(i, 1) & arr(i, 2)), D(arr(i, 5))) = _
arrRT(Dmon(arr(i, 1) & arr(i, 2)), D(arr(i, 5))) + arr(i, 4)
Next i
End With
Next iWs
Sheet2.Range("C2").Resize(Dmon.Count, D.Count) = arrRT
Sheet2.Range("C1").Resize(1, D.Count) = D.Keys
End Sub
'===================================================================================================
Sub 必做一_1_by_rxj_0414()
Dim D As New Dictionary
Dim i%, j%, arr, arrRS(), arrCnt(), r%, c%, arrTitle()
arrTitle = Application.Transpose(Application.Transpose(Sheet1.Range("A1:D1").Value))
arr = Sheet1.Range("A2:D" & Sheet1.Cells(Sheet1.Rows.Count, 4).End(xlUp).Row).Value
For i = 1 To UBound(arr)
D(arr(i, 1)) = D.Count
Next i
ReDim arrRS(1 To 5 * D.Count, 4)
ReDim arrCnt(1 To D.Count)
For i = 1 To UBound(arr)
arrCnt(D(arr(i, 1))) = arrCnt(D(arr(i, 1))) + 1
r = 2 + (D(arr(i, 1)) - 1) * 5 + (arrCnt(D(arr(i, 1))) - 1) Mod 4
c = ((arrCnt(D(arr(i, 1))) - 1) \ 4) * 5 + 1
If c > UBound(arrRS, 2) Then ReDim Preserve arrRS(1 To 5 * D.Count, c + 3)
For j = 0 To 3
arrRS(r, c + j) = arr(i, j + 1)
Next j
Next i
For i = 1 To D.Count
For j = 1 To 4
arrRS(1 + (i - 1) * 5, j) = arrTitle(j)
Next j
Next i
Sheet1.Range("F1").Resize(UBound(arrRS), UBound(arrRS, 2)) = arrRS
End Sub
'===================================================================================================
Sub 必做一_2_by_rxj_0414()
Dim D As New Dictionary
Dim i%, j%, arr, arrRS(), arrCnt(), r%, c%, arrTitle(), arrRow(), iRow()
arrTitle = Application.Transpose(Application.Transpose(Sheet1.Range("A1:D1").Value))
arr = Sheet1.Range("A2:D" & Sheet1.Cells(Sheet1.Rows.Count, 4).End(xlUp).Row).Value
For i = 1 To UBound(arr)
D(arr(i, 1)) = D.Count
Next i
ReDim arrCnt(1 To D.Count)
ReDim arrRow(1 To D.Count)
ReDim iRow(1 To D.Count)
For i = 1 To UBound(arrCnt)
arrCnt(i) = 1
Next i
For i = 1 To UBound(arr)
arrCnt(D(arr(i, 1))) = arrCnt(D(arr(i, 1))) + 1
Next i
For i = 1 To UBound(arrCnt)
arrRow(i) = arrCnt(i) \ 3 + IIf(arrCnt(i) Mod 3 = 0, 0, 1)
If arrRow(i) < 5 Then arrRow(i) = 5
arrCnt(i) = 1
If i > 1 Then
iRow(i) = iRow(i - 1) + arrRow(i - 1)
Else
iRow(i) = 1
End If
Next i
ReDim arrRS(1 To iRow(D.Count) + arrRow(D.Count) - 1, 5 * 3 - 1)
For i = 1 To UBound(arr)
arrCnt(D(arr(i, 1))) = arrCnt(D(arr(i, 1))) + 1
r = iRow(D(arr(i, 1))) + (arrCnt(D(arr(i, 1))) - 1) Mod arrRow(D(arr(i, 1)))
c = ((arrCnt(D(arr(i, 1))) - 1) \ arrRow(D(arr(i, 1)))) * 5 + 1
For j = 0 To 3
arrRS(r, c + j) = arr(i, j + 1)
Next j
Next i
For i = 1 To D.Count
For j = 1 To 4
arrRS(iRow(i), j) = arrTitle(j)
Next j
Next i
Sheet1.Range("F25").Resize(UBound(arrRS), UBound(arrRS, 2)) = arrRS
End Sub
'===================================================================================================

复制代码

qushui · 发表于 2012-1-3 15:53

本帖最后由 wcymiss 于 2012-1-13 21:18 编辑

来交作业了这次可以被批改了希望可以得到老师的优化建议!

Sub 效果一()
Dim arr, bb, ss, d As Object, brr(1 To 50, 1 To 50)
Dim a%, hh%, lh%
Set d = CreateObject("scripting.dictionary")
arr = Range("a1:d" & Cells(Rows.Count, 1).End(3).Row).Value
For i = 2 To UBound(arr)
If d.Exists(arr(i, 1)) Then
d(arr(i, 1)) = d(arr(i, 1)) & "|" & i
Else
d.Add arr(i, 1), i
End If
Next i
ss = d.items
For i = 0 To d.Count - 1
a = 1 + i * 5
brr(a, 1) = arr(1, 1): brr(a, 2) = arr(1, 2): brr(a, 3) = arr(1, 3): brr(a, 4) = arr(1, 4)
bb = Split(ss(i), "|")
For j = 0 To UBound(bb)
hh = j Mod 4 + a + 1
lh = (j \ 4) * 5
brr(hh, lh + 1) = arr(bb(j), 1): brr(hh, lh + 2) = arr(bb(j), 2): brr(hh, lh + 3) = arr(bb(j), 3): brr(hh, lh + 4) = arr(bb(j), 4)
Next j
Next i
[f1].Resize(50, 50) = brr
Set d = Nothing
End Sub

复制代码

Sub 效果二()
Dim arr, bb, ss, d As Object, brr(1 To 50, 1 To 15)
Dim a%, hh%, lh%
Set d = CreateObject("scripting.dictionary")
arr = Range("a1:d" & Cells(Rows.Count, 1).End(3).Row).Value
For i = 2 To UBound(arr)
If d.Exists(arr(i, 1)) Then
d(arr(i, 1)) = d(arr(i, 1)) & "|" & i
Else
d.Add arr(i, 1), "1|" & i
End If
Next i
ss = d.items
For i = 0 To d.Count - 1
bb = Split(ss(i), "|")
For j = 0 To UBound(bb)
hh = a + j Mod 5 + 1 + (j \ 15) * 5
lh = (j \ 5) * 5 - (j \ 15) * 15
brr(hh, lh + 1) = arr(bb(j), 1): brr(hh, lh + 2) = arr(bb(j), 2): brr(hh, lh + 3) = arr(bb(j), 3): brr(hh, lh + 4) = arr(bb(j), 4)
Next j
a = (hh \ 5 + 1) * 5
Next i
[f51].Resize(50, 15) = brr
Set d = Nothing
End Sub

复制代码

Sub 必做二()
Dim arr1, arr2, brr(1 To 13, 1 To 20), d1 As New Dictionary, d2 As New Dictionary
Dim k%, b%
With Sheets("必二1")
arr1 = .Range("a2:e" & .Cells(.Rows.Count, 1).End(3).Row).Value
End With
With Sheets("必二2")
arr2 = .Range("a2:e" & .Cells(.Rows.Count, 1).End(3).Row).Value
End With
For i = 1 To UBound(arr1)
If Not d1.Exists(arr1(i, 2)) Then
d1.Add arr1(i, 2), arr1(i, 2) + 1
End If
If Not d2.Exists(arr1(i, 5)) Then
k = k + 1: d2.Add arr1(i, 5), k: brr(1, k) = arr1(i, 5)
End If
brr(d1(arr1(i, 2)), d2(arr1(i, 5))) = brr(d1(arr1(i, 2)), d2(arr1(i, 5))) + arr1(i, 4)
Next i
For i = 1 To UBound(arr2)
If Not d1.Exists(arr2(i, 2)) Then
d1.Add arr2(i, 2), arr2(i, 2) + 1
End If
If Not d2.Exists(arr2(i, 5)) Then
k = k + 1: d2.Add arr2(i, 5), k: brr(1, k) = arr2(i, 5)
End If
brr(d1(arr2(i, 2)), d2(arr2(i, 5))) = brr(d1(arr2(i, 2)), d2(arr2(i, 5))) + arr2(i, 4)
Next i
Set d1 = Nothing: Set d2 = Nothing
Range(Cells(1, 3), Cells(13, 22)).ClearContents
Range(Cells(1, 3), Cells(13, 22)) = brr
End Sub

复制代码

Sub 选做()
Dim arr, brr, da As New Dictionary, db As New Dictionary, dc As New Dictionary
Dim crr(1 To 200) As String, s1$, s2$, s3$
arr = [h1].CurrentRegion.Value
For i = 2 To UBound(arr)
s1 = arr(i, 1) & arr(i, 2)
da(s1) = i
For j = 6 To UBound(arr, 2) Step 2
If arr(i, j) = "" Then Exit For
arr(i, j) = arr(i, j - 2) + arr(i, j)
Next j
db(s1) = j - 2
Next i
brr = Range("b2:d" & Cells(Rows.Count, 2).End(3).Row).Value
For i = 1 To UBound(brr)
s2 = brr(i, 1) & brr(i, 2)
dc(s2) = dc(s2) + brr(i, 3)
If Not da.Exists(s2) Then
If InStr(s3, s2) = 0 Then s3 = s3 & " " & s2
Else
If dc(s2) <= arr(da(s2), db(s2)) Then
For j = 4 To db(s2) Step 2
If dc(s2) <= arr(da(s2), j) Then crr(i) = arr(da(s2), j - 1): Exit For
Next j
Else
crr(i) = arr(da(s2), db(s2) - 1)
End If
End If
Next i
Set da = Nothing: Set db = Nothing: Set dc = Nothing
[e2].Resize(200, 1).ClearContents
[e2].Resize(200, 1) = Application.Transpose(crr)
If s3 <> "" Then
MsgBox "以下型号及产品在编码表中不存在：" & Chr(13) & s3
End If
End Sub

复制代码

Sub 附加题()
Dim h1%, h2%, c%, c1%, c2%, s$, k%, t1&, t2&, temp1, temp2
Dim arr, brr, a, b, crr(), drr(1 To 8, 1 To 3), d As New Dictionary
With Sheets("附加1")
c = .Cells(3, Columns.Count).End(1).Column
For i = 5 To c
If InStr(Str(.Cells(3, i)), "-" & CStr(Cells(2, 5)) & "-") Then c1 = c1 + 1: c2 = i
Next i
h1 = .[a:a].Find([b2]).Row
h2 = .[B:B].Find(what:="", after:=.Range("b" & h1)).Row
arr = .Range(.Cells(h1, c2 - c1 + 1), .Cells(h2, c2)).Value
brr = .Range("c" & h1 & ":d" & .Cells(h2, 3).End(3).Row).Value
End With
For i = 1 To UBound(brr)
s = brr(i, 1) & "|" & brr(i, 2)
If Not d.Exists(s) Then k = k + 1: d.Add s, k: ReDim Preserve crr(1 To k)
For j = LBound(arr, 2) To UBound(arr, 2)
crr(d(s)) = crr(d(s)) + arr(i, j)
Next j
Next i
b = d.Keys
For i = 1 To 7
imax = i
For j = i + 1 To k - 1
If crr(j) > crr(imax) Then imax = j
Next j
temp1 = crr(i): crr(i) = crr(imax): crr(imax) = temp1
temp2 = b(i - 1): b(i - 1) = b(imax - 1): b(imax - 1) = temp2
drr(i, 3) = crr(i)
s = b(i - 1)
a = Split(s, "|")
drr(i, 1) = a(0): drr(i, 2) = a(1)
Next i
drr(8, 1) = "其他"
t1 = Application.Sum(Application.Index(arr, h2 - h1 + 1))
t2 = Application.Sum(crr)
drr(8, 3) = t2 - Application.Sum(Application.Index(drr, , 3))
[b5] = t1: [e5] = t2: [b8:d15].ClearContents: [b8:d15] = drr
Set d = Nothing
End Sub

复制代码

ldxhzy · 发表于 2012-1-3 17:44

Private Sub 必做一_ldxhzy()
Dim Sou(), Tmp(), Tmp1(), Tmp2()
Dim TmpD As New Dictionary
Dim I As Long, J As Long, M As Long, N As Long
I = Me.UsedRange.Rows.Count
ReDim Sou(1 To I - 1, 1 To 4)
Sou = Me.Range(Cells(2, 1), Cells(I, 4)).Value
For I = 1 To UBound(Sou, 1)
If TmpD.Exists(Sou(I, 1)) Then
TmpD.Item(Sou(I, 1)) = TmpD.Item(Sou(I, 1)) + 1
Else
TmpD.Add Sou(I, 1), 1
End If
Next I
Tmp1 = TmpD.Keys
Tmp2 = TmpD.Items
For I = LBound(Tmp1) To UBound(Tmp1)
J = (Int((Tmp2(I) - 1) / 4) + 1) * 4
ReDim Tmp(1 To J, 1 To 4)
M = 0
N = 0
For J = LBound(Sou, 1) To UBound(Sou, 1)
If Sou(J, 1) = Tmp1(I) Then
M = M + 1
Tmp(M, 1) = Sou(J, 1)
Tmp(M, 2) = Sou(J, 2)
Tmp(M, 3) = Sou(J, 3)
Tmp(M, 4) = Sou(J, 4)
End If
Next J
Cells(I * 5 + 1, 6).Resize(1, 4) = Array("仓库名称", "序号", "商品代码", "数量")
M = 0
For J = 1 To UBound(Tmp, 1)
Cells(I * 5 + J + N + 1, 6 + M).Resize(1, 4) = Array(Tmp(J, 1), Tmp(J, 2), Tmp(J, 3), Tmp(J, 4))
If J / 4 = Int(J / 4) Then
M = M + 4
N = N - 4
End If
Next J
Next I
End Sub

复制代码

Private Sub 必做二_ldxhzy()
Dim Sou1(), Sou2(), Sou(), Tag()
Dim I As Long, J As Long
I = ThisWorkbook.Sheets("必二1").UsedRange.Rows.Count
Sou1() = ThisWorkbook.Sheets("必二1").Range("A2:" & "E" & I).Value
J = ThisWorkbook.Sheets("必二2").UsedRange.Rows.Count
Sou2() = ThisWorkbook.Sheets("必二2").Range("A2:" & "E" & J).Value
ReDim Sou(1 To I + J - 2, 1 To 4)
For I = 1 To UBound(Sou1, 1)
Sou(I, 1) = Sou1(I, 1)
Sou(I, 2) = Sou1(I, 2)
Sou(I, 3) = Sou1(I, 4)
Sou(I, 4) = Sou1(I, 5)
Next I
For I = UBound(Sou1, 1) + 1 To UBound(Sou1, 1) + UBound(Sou2, 1)
Sou(I, 1) = Sou2(I - UBound(Sou1, 1), 1)
Sou(I, 2) = Sou2(I - UBound(Sou1, 1), 2)
Sou(I, 3) = Sou2(I - UBound(Sou1, 1), 4)
Sou(I, 4) = Sou2(I - UBound(Sou1, 1), 5)
Next I
Dim XmDic As New Dictionary
Dim XmArr()
For I = 1 To UBound(Sou, 1) '取得所有不同的项目名称
XmDic(Sou(I, 4)) = Sou(I, 4)
Next I
XmArr = XmDic.Keys
ReDim Tag(1 To 13, 1 To XmDic.Count)
For I = 0 To UBound(XmArr)
Tag(1, I + 1) = XmArr(I) '项目名称填入数组第一行
For J = 1 To UBound(Sou, 1)
If Sou(J, 4) = XmArr(I) Then
Tag(Sou(J, 2) + 1, I + 1) = Tag(Sou(J, 2) + 1, I + 1) + Sou(J, 3)
End If
Next J
Next I
Range("C1").Resize(13, XmDic.Count) = Tag
End Sub

复制代码

Private Sub 选做_ldxhzy()
Rem 以手工方式将判断表转换为 4 个数组，每数组行内容为：编码、上限，不支持向下、向右扩展
Dim A上海(1 To 5, 1 To 2)
A上海(1, 1) = "SH01"
A上海(1, 2) = 2300
A上海(2, 1) = "SH02"
A上海(2, 2) = 2300 + 3420
A上海(3, 1) = "SH03"
A上海(3, 2) = 2300 + 3420 + 4100
A上海(4, 1) = "SH04"
A上海(4, 2) = 2300 + 3420 + 4100 + 1400
A上海(5, 1) = "SH05"
A上海(5, 2) = 2300 + 3420 + 4100 + 1400 + 0 '此条件不用判断，对应 CASE ELSE
Dim B上海(1 To 3, 1 To 2)
B上海(1, 1) = "SH06"
B上海(1, 2) = 2100
B上海(2, 1) = "SH07"
B上海(2, 2) = 2100 + 1090
B上海(3, 1) = "SH08"
B上海(3, 2) = 2100 + 1090 + 0 '此条件不用判断，对应 CASE ELSE
Dim A广州(1 To 2, 1 To 2)
A广州(1, 1) = "GZ01"
A广州(1, 2) = 4300
A广州(2, 1) = "GZ02"
A广州(2, 2) = 4300 + 0 '此条件不用判断，对应 CASE ELSE
Dim B广州(1 To 4, 1 To 2)
B广州(1, 1) = "GZ03"
B广州(1, 2) = 2380
B广州(2, 1) = "GZ04"
B广州(2, 2) = 2380 + 4300
B广州(3, 1) = "GZ05"
B广州(3, 2) = 2380 + 4300 + 2100
B广州(4, 1) = "GZ06"
B广州(4, 2) = 2380 + 4300 + 2100 + 0 '此条件不用判断，对应 CASE ELSE
Dim Sou(), Tag()
Dim MyDic As New Dictionary
Dim I As Long
I = Me.UsedRange.Rows.Count - 1
ReDim Sou(1 To I, 3)
Sou = Range("B2").Resize(I, 3)
For I = 1 To UBound(Sou, 1)
If MyDic.Exists(Sou(I, 1) & Sou(I, 2)) Then
MyDic.Item(Sou(I, 1) & Sou(I, 2)) = MyDic.Item(Sou(I, 1) & Sou(I, 2)) + Sou(I, 3)
Else
MyDic.Add Sou(I, 1) & Sou(I, 2), Val(Sou(I, 3))
End If
ReDim Preserve Tag(1 To I)
Select Case Sou(I, 1) & Sou(I, 2)
Case "A上海"
Select Case MyDic.Item(Sou(I, 1) & Sou(I, 2))
Case Is <= A上海(1, 2)
Tag(I) = A上海(1, 1)
Case Is <= A上海(2, 2)
Tag(I) = A上海(2, 1)
Case Is <= A上海(3, 2)
Tag(I) = A上海(3, 1)
Case Is <= A上海(4, 2)
Tag(I) = A上海(4, 1)
Case Else
Tag(I) = A上海(5, 1)
End Select
Case "B上海"
Select Case MyDic.Item(Sou(I, 1) & Sou(I, 2))
Case Is <= B上海(1, 2)
Tag(I) = B上海(1, 1)
Case Is <= B上海(2, 2)
Tag(I) = B上海(2, 1)
Case Else
Tag(I) = B上海(3, 1)
End Select
Case "A广州"
Select Case MyDic.Item(Sou(I, 1) & Sou(I, 2))
Case Is <= A广州(1, 2)
Tag(I) = A广州(1, 1)
Case Else
Tag(I) = A广州(2, 1)
End Select
Case "B广州"
Select Case MyDic.Item(Sou(I, 1) & Sou(I, 2))
Case Is <= B广州(1, 2)
Tag(I) = B广州(1, 1)
Case Is <= B广州(2, 2)
Tag(I) = B广州(2, 1)
Case Is <= B广州(3, 2)
Tag(I) = B广州(3, 1)
Case Else
Tag(I) = B广州(4, 1)
End Select
Case Else
Tag(I) = ""
MsgBox "关键字 " & Sou(I, 1) & Sou(I, 2) & " 不存在！"
End Select
Next I
Range("E2").Resize(UBound(Tag, 1), 1) = Application.WorksheetFunction.Transpose(Tag)
End Sub

复制代码

EP学员 · 发表于 2012-1-3 20:16

Sub 必做一_效果一_EP学员()
Dim brr(1 To 10000, 1 To 50)
Dim arr, arr1, 行标 As Long, 列标 As Byte, 步长 As Byte, i As Long, k As Integer, imax As Integer
Dim dic As New Dictionary
With Sheets("必做一")
arr1 = [{"仓库名称","序号","商品代码","数量",""}]
arr = .Range("a1:e" & Range("a65536").End(xlUp).Row)
For i = 2 To UBound(arr)
If Not dic.Exists(arr(i, 1)) Then
行标 = (dic.Count) * 5 + 1
dic(arr(i, 1)) = 1
列标 = 0
For k = 1 To 5
brr(行标, k) = arr1(k)
brr(行标 + 1, 列标 + k) = arr(i, k)
Next
Else
dic(arr(i, 1)) = dic(arr(i, 1)) + 1
列标 = (dic(arr(i, 1)) \ 5) * 5
步长 = (dic(arr(i, 1)) - 1) Mod 4 + 1
If imax < 列标 Then imax = 列标
For k = 1 To 5
brr(行标 + 步长, 列标 + k) = arr(i, k)
Next
End If
Next
.Range("g2").Resize(dic.Count * 5, imax) = brr
End With
End Sub
Sub 必做二_EP学员()
Dim d As New Dictionary
Dim arr, i, sh, brr(), k
For Each sh In Array(Sheets("必二1"), Sheets("必二2"))
arr = sh.Range("a1").CurrentRegion
For i = 2 To UBound(arr)
If Not d.Exists(arr(i, 5)) Then
k = k + 1
d(arr(i, 5)) = k
ReDim Preserve brr(1 To 12, 1 To k)
End If
brr(arr(i, 2), d(arr(i, 5))) = brr(arr(i, 2), d(arr(i, 5))) + arr(i, 4)
Next i
Next
With Sheets("必做二")
.Range("c:z").ClearContents
.[c1].Resize(1, d.Count) = d.Keys
.[c2].Resize(12, UBound(brr, 2)) = brr
End With
End Sub

复制代码

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

[习题] [字典与数组二期1班] 第3讲作业上交帖

评分

相关帖子

点评

评分

评分

评分

评分

评分

评分

点评

评分

评分