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

sliang28 · 发表于 2013-10-17 12:18

本帖最后由 sliang28 于 2013-10-22 15:10 编辑

根据习题一的结果,你们都太强了,于是有了习题一的升级版.

继续拼时间{:3912:}

gdw831001 · 发表于 2013-10-17 12:23

本帖最后由 gdw831001 于 2013-10-18 07:45 编辑

占个位置等结果,我只是占个位置了，何况您的题目上也没有说不能，可不能~~~~~~

hrpotter · 发表于 2013-10-17 14:09

Sub test()
Dim i As Long, j As Long, k As Long, t As Single
Dim arr, brr(1 To 1000, 1 To 10) As String, crr(1 To 3) As Long
t = Timer
On Error Resume Next
arr = Sheet12.Range("a2:g449")
k = 1
For i = 1 To UBound(arr)
If i = 1 Or arr(i, 1) <> arr(i - 1, 1) Then
brr(k, 1) = arr(i, 1)
brr(k, 2) = arr(i, 2)
brr(k, 3) = "CAP前"
brr(k + 1, 3) = "CAP后"
brr(k + 2, 3) = "完成品"
k = k + 3
Erase crr
End If
For j = 5 To 7
If arr(i, j) > 0 Then
crr(j - 4) = crr(j - 4) + 1
brr(k + j - 8, crr(j - 4) + 3) = arr(i, 3)
End If
Next
Next
With Sheet4
.Range("a2:j65536").ClearContents
.Range("a2").Resize(k - 1, 10) = brr
End With
MsgBox Timer - t
End Sub

复制代码

CheryBTL · 发表于 2013-10-17 14:18

本帖最后由 CheryBTL 于 2013-10-18 10:18 编辑

先凑一个了，如果学委能提前给出时间要求最好了：

Sub CheryBTL()
Dim i As Integer, m As Integer
Dim n1 As Integer, n2 As Integer, n3 As Integer
Dim ar, Re() As String
Dim t As Single
t = Timer
ar = Sheets("数据源").Range("A1").CurrentRegion
ReDim Re(1 To (UBound(ar) / 7) * 3, 1 To 10) As String
For i = 2 To UBound(ar)
If i Mod 7 = 2 Then n1 = 0: n2 = 0: n3 = 0：m=(i-2)/7*3+1
Re(m, 3) = "CAP前"
Re(m + 1, 3) = "CAP后"
Re(m + 2, 3) = "完成品"
If i Mod 7 = 2 Then Re(m, 1) = ar(i, 1): Re(m, 2) = ar(i, 2)
If ar(i, 5) <> "" Then n1 = n1 + 1: Re(m, 3 + n1) = ar(i, 3)
If ar(i, 6) <> "" Then n2 = n2 + 1: Re(m + 1, 3 + n2) = ar(i, 3)
If ar(i, 7) <> "" Then n3 = n3 + 1: Re(m + 2, 3 + n3) = ar(i, 3)
Next i
With Sheets("结果")
.Range("A2").CurrentRegion.ClearContents
.Range("A2").Resize(UBound(Re), 10) = Re
End With
MsgBox Timer - t
End Sub

复制代码

再改下，把VBA函数MOD和INT完全省略掉，也有出现0的，哈哈：

Sub CheryBTL2()
Dim i As Integer, m As Integer, j As Integer
Dim n1 As Integer, n2 As Integer, n3 As Integer
Dim ar, Re() As String
Dim t As Single
t = Timer
With Sheets("数据源")
ar = .Range("A1").CurrentRegion
End With
ReDim Re(1 To UBound(ar) / 7 * 3, 1 To 10) As String
j = 2
m = -2
For i = 2 To UBound(ar)
If i = j Then
j = j + 7
m = m + 3
Re(m, 1) = ar(i, 1): Re(m, 2) = ar(i, 2)
n1 = 3: n2 = 3: n3 = 3
End If
Re(m, 3) = "CAP前"
Re(m + 1, 3) = "CAP后"
Re(m + 2, 3) = "完成品"
If ar(i, 5) <> "" Then n1 = n1 + 1: Re(m, n1) = ar(i, 3)
If ar(i, 6) <> "" Then n2 = n2 + 1: Re(m + 1, n2) = ar(i, 3)
If ar(i, 7) <> "" Then n3 = n3 + 1: Re(m + 2, n3) = ar(i, 3)
Next i
With Sheets("结果")
.Range("A2").CurrentRegion.ClearContents
.Range("A2").Resize(UBound(Re), 10) = Re
End With
MsgBox Timer - t
End Sub

复制代码

再次减少循环的次数：

Sub CheryBTL3() '再减少参数
Dim i As Integer, j As Integer
Dim n1 As Integer, n2 As Integer, n3 As Integer
Dim ar, Re() As String
Dim t As Single
t = Timer
With Sheets("数据源")
ar = .Range("A1").CurrentRegion
End With
ReDim Re(1 To UBound(ar) / 7 * 3, 1 To 10) As String
m = -2
For i = 2 To UBound(ar) Step 7
m = m + 3
Re(m, 1) = ar(i, 1): Re(m, 2) = ar(i, 2)
n1 = 3: n2 = 3: n3 = 3
Re(m, 3) = "CAP前"
Re(m + 1, 3) = "CAP后"
Re(m + 2, 3) = "完成品"
For j = 0 To 6
If ar(i + j, 5) <> "" Then n1 = n1 + 1: Re(m, n1) = ar(i, 3)
If ar(i + j, 6) <> "" Then n2 = n2 + 1: Re(m + 1, n2) = ar(i, 3)
If ar(i + j, 7) <> "" Then n3 = n3 + 1: Re(m + 2, n3) = ar(i, 3)
Next j
Next i
With Sheets("结果")
.Range("A2").CurrentRegion.ClearContents
.Range("A2").Resize(UBound(Re), 10) = Re
End With
MsgBox Timer - t
End Sub

复制代码

Sellby · 发表于 2013-10-17 22:23

Sub sellby()
Dim arr, brr(1 To 600, 1 To 20)
Dim d As New Dictionary
Dim i%, n%, x As Byte, y As Byte, z As Byte, m As Byte
Dim str$, t
t = Timer
arr = Sheets("数据源").Cells(1, 1).CurrentRegion
n = -2
For i = 2 To UBound(arr)
str = arr(i, 1) & "/" & arr(i, 2)
If Not d.Exists(str) Then
n = n + 3
d.Add str, n
brr(n, 1) = arr(i, 1)
brr(n, 2) = arr(i, 2)
brr(n, 3) = arr(1, 5)
brr(n + 1, 3) = arr(1, 6)
brr(n + 2, 3) = arr(1, 7)
x = 3: y = 3: z = 3
If arr(i, 5) > 0 Then x = x + 1: brr(n, x) = arr(i, 3)
If arr(i, 6) > 0 Then y = y + 1: brr(n + 1, y) = arr(i, 3)
If arr(i, 7) > 0 Then z = z + 1: brr(n + 2, z) = arr(i, 3)
Else
If arr(i, 5) > 0 Then x = x + 1: brr(n, x) = arr(i, 3)
If arr(i, 6) > 0 Then y = y + 1: brr(n + 1, y) = arr(i, 3)
If arr(i, 7) > 0 Then z = z + 1: brr(n + 2, z) = arr(i, 3)
End If
m = Application.Max(m, x, y, z)
Next i
' Stop
With Sheets("结果")
.Cells.ClearContents
.Cells(2, 1).Resize(d.Count * 3, m) = brr
End With
Set d = Nothing
MsgBox Timer - t
End Sub

复制代码

木牙水 · 发表于 2013-10-18 09:16

Sub 热身()
Dim arr, brr(1 To 192, 1 To 10)
Dim i As Integer, j As Integer, t
t = Timer
j = 1
arr = Sheets("数据源").Range("a2:g" & Sheets("数据源").Range("a65536").End(3).Row)
For i = 1 To UBound(arr) Step 7
brr(j, 1) = arr(i, 1)
brr(j, 2) = arr(i, 2)
brr(j, 3) = "CAP前"
brr(j, 4) = arr(i + 2, 3)
brr(j, 5) = arr(i + 3, 3)
brr(j, 6) = arr(i + 4, 3)
brr(j, 7) = arr(i + 5, 3)
brr(j, 8) = arr(i + 6, 3)
brr(j + 1, 3) = "CAP后"
brr(j + 1, 4) = arr(i, 3)
brr(j + 1, 5) = arr(i + 2, 3)
brr(j + 1, 6) = arr(i + 3, 3)
brr(j + 1, 7) = arr(i + 4, 3)
brr(j + 1, 8) = arr(i + 5, 3)
brr(j + 1, 9) = arr(i + 6, 3)
brr(j + 2, 3) = "完成品"
brr(j + 2, 4) = arr(i, 3)
brr(j + 2, 5) = arr(i + 1, 3)
brr(j + 2, 6) = arr(i + 2, 3)
brr(j + 2, 7) = arr(i + 3, 3)
brr(j + 2, 8) = arr(i + 4, 3)
brr(j + 2, 9) = arr(i + 5, 3)
brr(j + 2, 10) = arr(i + 6, 3)
j = j + 3
Next i
Sheet4.Range("a2").Resize(192, 10) = brr
MsgBox Timer - t
End Sub

复制代码

hoogle · 发表于 2013-10-20 20:20

Sub hoogle()
Dim t As Double
t = Timer
Dim arrData, i As Integer, j As Integer, icount(1 To 3)
arrData = Sheets("数据源").Range("a2:g449").Value
Dim arrRes(1 To 192, 1 To 10)
For i = 1 To UBound(arrData) / 7 * 3 Step 3
icount(1) = 4: icount(2) = 4: icount(3) = 4
arrRes(i, 1) = arrData(i / 3 * 7, 1)
arrRes(i, 2) = arrData(i / 3 * 7, 2)
arrRes(i, 3) = "CAP前": arrRes(i + 1, 3) = "CAP后": arrRes(i + 2, 3) = "完成品"
For j = 1 To 7
If arrData((i - 1) / 3 * 7 + j, 5) <> "" Then
arrRes(i, icount(1)) = arrData((i - 1) / 3 * 7 + j, 3)
icount(1) = icount(1) + 1
End If
If arrData((i - 1) / 3 * 7 + j, 6) <> "" Then
arrRes(i + 1, icount(2)) = arrData((i - 1) / 3 * 7 + j, 3)
icount(2) = icount(2) + 1
End If
If arrData((i - 1) / 3 * 7 + j, 7) <> "" Then
arrRes(i + 2, icount(3)) = arrData((i - 1) / 3 * 7 + j, 3)
icount(3) = icount(3) + 1
End If
Next
Next
Sheets("结果").UsedRange.ClearContents
Sheets("结果").Range("a2").Resize(192, 10) = arrRes
MsgBox Timer - t
End Sub

复制代码

w2001pf · 发表于 2013-10-20 21:47

热身题之格式转换-升级版.zip (43.29 KB, 下载次数: 5)

fffox · 发表于 2013-10-21 16:16

本帖最后由 fffox 于 2013-10-21 16:22 编辑

前几天写好的，今天拿出来又改了一下，发上来请老师点评

Sub t()
Dim arr, t
Dim brr() As String
Dim i As Long, k As Long, k1 As Integer, k2 As Integer, k3 As Integer
Dim maxk As Integer, maxcol As Integer
t = Timer
Application.ScreenUpdating = False
With Sheets("数据源")
arr = .Range("a1:g" & .Cells(Rows.Count, "g").End(xlUp).Row)
End With
ReDim brr(1 To 1000, 1 To 10) As String
k = -2
For i = 2 To UBound(arr)
If arr(i - 1, 1) <> arr(i, 1) Then
k = k + 3: k1 = 4: k2 = 4: k3 = 4
brr(k, 1) = arr(i, 1) '设Product Code
brr(k, 2) = arr(i, 2) '设Product Name
brr(k, 3) = arr(1, 5) '设CAP前
brr(k + 1, 3) = arr(1, 6) '设CAP后
brr(k + 2, 3) = arr(1, 7) '设完成品
End If
If arr(i, 5) <> "" Then
brr(k, k1) = arr(i, 3) 'CAP前对应的Material Code
k1 = k1 + 1
End If
If arr(i, 6) <> "" Then
brr(k + 1, k2) = arr(i, 3) 'CAP后对应的Material Code
k2 = k2 + 1
End If
If arr(i, 7) <> "" Then
brr(k + 2, k3) = arr(i, 3) '完成品对应的Material Code
k3 = k3 + 1
End If
maxk = Application.Max(k1, k2, k3)
If maxcol < maxk Then maxcol = maxk
If maxcol > UBound(brr, 2)+1 Then ReDim Preserve brr(1 To 1000, 1 To maxcol) As String
Next
With Sheets("结果")
.Cells.ClearContents
.Range("a2").Resize(k + 2, UBound(brr, 2)) = brr
End With
Application.ScreenUpdating = True
Debug.Print Timer - t
End Sub

复制代码

wp8680 · 发表于 2013-10-21 22:09

Sub aa()
Dim arr, brr(), crr
Dim iend%, k%, m%, n%, a%, b%
Dim t: t = Timer
iend = Sheets("数据源").Range("a" & Cells.Rows.Count).End(xlUp).Row
arr = Sheets("数据源").Range("a2:g" & iend)
crr = Sheets("数据源").Range("e1:g1")
ReDim brr(1 To UBound(arr) / 7 * 3, 1 To 10)
m = 1
For k = 1 To UBound(arr) Step 7
brr(m, 1) = arr(k, 1)
brr(m, 2) = arr(k, 2)
For n = 1 To 3
b = 0
brr(m + n - 1, 3) = crr(1, n)
For a = 1 To 7
If arr(k + a - 1, 4 + n) <> "" Then
b = b + 1
brr(m + n - 1, 3 + b) = arr(k + a - 1, 3)
End If
Next a
Next n
m = m + 3
Next k
Sheets("结果").Range("l2").Resize(UBound(brr), UBound(brr, 2)) = brr
MsgBox Timer - t
End Sub

复制代码

我的电脑上测是0.015625

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

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

评分

点评

点评

点评

点评

点评

点评

点评

点评

点评

评分