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

sliang28 · 发表于 2013-10-15 18:36

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

字典班的兄弟姐妹们:
饭都吃饱了吧!
作道题帮助消化消化……
快来下载附件吧，惊喜多多{:3912:}

在我电脑上测试在0.2秒内完成的，惊喜多多……

烟花的BB发不出去，你们快来拿吧{:2312:}

Sub sliang28()
Dim arr, brr, i%, j%, x%, n%
t = Timer
arr = Sheets("数据源").Range("A1:JD3977")
ReDim brr(10 To UBound(arr), 1 To 7) As String
n = 10
For j = 7 To UBound(arr, 2)
      For i = n To UBound(arr)
         If i = n Then
            For x = 1 To 4
                  brr(i, x) = arr(x + 2, j)
            Next
         End If
         If Len(arr(i, j)) = 0 Then Exit For
         brr(i, 5) = arr(i, 2)
         brr(i, 6) = arr(i, 5)
         brr(i, 7) = arr(i, j)
      Next
      n = i
Next
With Sheets("结果")
      .Range("A1:G3977").ClearContents
      '.Range("A1:G3978") = ""
      .Range("A2").Resize(i - 10, 7) = brr
End With
MsgBox Timer - t
End Sub

jio1ye · 发表于 2013-10-15 18:47

我还想挑战一下，不是这个级别人士啊。╮(╯▽╰)╭。

CheryBTL · 发表于 2013-10-15 21:15

先来个没有技术含量的，纯粹是一个个放进去的：

Sub CheryBTL()
Dim i As Integer, j As Integer, Rnum As Integer
Dim ar, re
Rnum = Sheets("数据源").[A65536].End(3).Row
ar = Sheets("数据源").Range("A1:JD" & Rnum)
ReDim re(1 To Rnum, 1 To 7)
For j = 7 To UBound(ar, 2)
For i = 10 To UBound(ar)
If ar(i, j) = 1 Then
If ar(i - 1, j) = 0 Then
re(i - 8, 1) = ar(3, j): re(i - 8, 2) = ar(4, j): re(i - 8, 3) = ar(5, j): re(i - 8, 4) = ar(6, j)
End If
re(i - 8, 5) = ar(i, 2)
re(i - 8, 6) = ar(i, 5)
re(i - 8, 7) = 1
End If
Next i
Next j
Sheets("结果").[a1].Resize(Rnum, 7) = re
End Sub

复制代码

CheryBTL · 发表于 2013-10-15 21:40

本帖最后由 CheryBTL 于 2013-10-16 07:58 编辑

对同一个表时，再增加一个变量，想着会节省时间，但运行时没发现有变化，
将数组re,redim为string型变量，时间立马就降下来了，在台式电脑上运行为0.18s左右：

Sub CheryBTL1() '仅对一个源数据表
Dim i As Integer, j As Integer, Rnum As Integer, t As Single, temp As Integer
Dim ar, re
t = Timer
Rnum = Sheets("数据源").[A65536].End(3).Row
ar = Sheets("数据源").Range("A1:JD" & Rnum)
ReDim re(1 To Rnum, 1 To 7) as String
For j = 7 To UBound(ar, 2)
For i = 10 To UBound(ar)
If ar(i, j) = 1 Then
temp = i - 8
If ar(i - 1, j) = 0 Then
re(temp, 1) = ar(3, j): re(temp, 2) = ar(4, j): re(temp, 3) = ar(5, j): re(temp, 4) = ar(6, j)
End If
re(temp, 5) = ar(i, 2)
re(temp, 6) = ar(i, 5)
re(temp, 7) = 1
End If
Next i
Next j
Sheets("结果").[a1].Resize(Rnum, 7) = re
MsgBox Timer - t
End Sub

复制代码

多表时，增加一个工作表循环：

Sub CheryBTL2_1() '对多表时
Dim i As Integer, j As Integer, Rnum As Integer, m As Long
Dim ar, re(1 To 100000, 1 To 7) as String
Dim sht As Worksheet
t = Timer
m = 1
For Each sht In Worksheets
If sht.Name <> "结果" Then
Rnum = sht.[A65536].End(3).Row
ar = sht.Range("A1:JD" & Rnum)
For j = 7 To UBound(ar, 2)
For i = 10 To UBound(ar)
If ar(i, j) = 1 Then
m = m + 1
If ar(i - 1, j) = 0 Then
re(m, 1) = ar(3, j): re(m, 2) = ar(4, j): re(m, 3) = ar(5, j): re(m, 4) = ar(6, j)
End If
re(m, 5) = ar(i, 2)
re(m, 6) = ar(i, 5)
re(m, 7) = 1
End If
Next i
Next j
End If
Next
Sheets("结果").[a1].Resize(100000, 7) = re
MsgBox Timer - t
End Sub

复制代码

wp8680 · 发表于 2013-10-15 23:25

Option Explicit
Sub 转换数据()
Dim arr, brr, iend%, drr(), k%, m%, n As Boolean
Dim t: t = Timer
arr = Range("g3:jd6")
iend = Range("e" & Cells.Rows.Count).End(xlUp).Row
brr = Range("b10:jd" & iend)
ReDim drr(1 To UBound(brr), 1 To UBound(arr) + 3)
For k = 1 To UBound(brr)
If brr(k, 6 + m) = "" And n = True Then m = m + 1: n = False
If n = False Then
If brr(k, 6 + m) = 1 Then
drr(k, 1) = arr(1, m + 1)
drr(k, 2) = arr(2, m + 1)
drr(k, 3) = arr(3, m + 1)
drr(k, 4) = arr(4, m + 1)
drr(k, 5) = brr(k, 1)
drr(k, 6) = brr(k, 4)
drr(k, 7) = brr(k, 6 + m)
n = True
End If
Else
drr(k, 5) = brr(k, 1)
drr(k, 6) = brr(k, 4)
drr(k, 7) = brr(k, 6 + m)
End If
Next k
Sheets("结果").Range("i2").Resize(UBound(drr, 1), UBound(drr, 2)) = drr
MsgBox Timer - t
End Sub

复制代码

木牙水 · 发表于 2013-10-16 00:29

Sub 热身()
Dim arr, brr(1 To 3968, 1 To 4), i As Integer, j As Integer, k As Integer, arow As Integer
Set arr = Sheet1.Range("g3:jd6")
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
arow = Sheet1.Range("a65536").End(xlUp).Row
For i = 10 To arow
d1(i) = Sheet1.Cells(i, 2).Value '品名
d2(i) = Sheet1.Cells(i, 5).Value '规格
d3(i) = Application.WorksheetFunction.Sum(Range(Cells(i, 7), Cells(i, 264)))
Next i
k = 0
For j = 7 To 264 Step 1
If j = 7 Then
brr(1, 1) = Sheet1.Cells(3, 7).Value
brr(1, 2) = Sheet1.Cells(4, 7).Value
brr(1, 3) = Sheet1.Cells(5, 7).Value
brr(1, 4) = Sheet1.Cells(6, 7).Value
Else
k = Application.WorksheetFunction.CountIf(Range(Cells(10, j - 1), Cells(3977, j - 1)), ">0") + k
brr(k + 1, 1) = Sheet1.Cells(3, j).Value
brr(k + 1, 2) = Sheet1.Cells(4, j).Value
brr(k + 1, 3) = Sheet1.Cells(5, j).Value
brr(k + 1, 4) = Sheet1.Cells(6, j).Value
End If
Next j
Sheet2.[e2].Resize(d1.Count, 1) = Application.Transpose(d1.items)
Sheet2.[f2].Resize(d2.Count, 1) = Application.Transpose(d2.items)
Sheet2.[g2].Resize(d3.Count, 1) = Application.Transpose(d3.items)
Sheet2.[a2].Resize(3968, 4) = brr
End Sub

复制代码

做的好纠结啊！

木牙水-热身题之格式转换.rar (488.27 KB, 下载次数: 16)

hoogle · 发表于 2013-10-16 11:41

本帖最后由 hoogle 于 2013-10-16 11:45 编辑

Sub hoogle()
Dim t As Long
t = Timer
Dim arr1, arr2, i As Integer, j As Integer, arrRes() As String, temp As Integer
With Sheets("数据源")
arr1 = .Range(.Range("a10"), .Cells(Rows.Count, .Range("g8").End(xlToRight).Column).End(3)).Value
arr2 = .Range(.Range("g1"), .Range("g8").End(xlToRight)).Value
End With
temp = 1
ReDim arrRes(1 To UBound(arr1), 1 To 7)
For i = 1 To UBound(arrRes)
arrRes(i, 5) = arr1(i, 2)
arrRes(i, 6) = arr1(i, 5)
Do Until arr1(i, temp + 6) <> ""
temp = temp + 1
Loop
arrRes(i, 1) = arr2(3, temp)
arrRes(i, 2) = arr2(4, temp)
arrRes(i, 3) = arr2(5, temp)
arrRes(i, 4) = arr2(6, temp)
arrRes(i, 7) = arr1(i, temp + 6)
If arr2(3, temp) <> "" Then
arr2(3, temp) = ""
arr2(3, temp) = ""
arr2(4, temp) = ""
arr2(5, temp) = ""
arr2(6, temp) = ""
End If
Next
With Sheets("结果")
.UsedRange.ClearContents
.Range("a2").Resize(UBound(arrRes), UBound(arrRes, 2)) = arrRes
End With
Debug.Print Timer - t
End Sub

复制代码

hrpotter · 发表于 2013-10-16 13:36

Sub test()
Dim arr, brr, crr
Dim i As Long, j As Long, k As Long, t
t = Timer
On Error Resume Next
Application.ScreenUpdating = False
With Sheet1
arr = .Range("a10:jd3977")
brr = .Range("g3:jd6")
End With
ReDim crr(1 To UBound(arr), 1 To 7) As String
k = 7
For i = 1 To UBound(arr)
If i = 1 Or arr(i - 1, k) = 0 Then
crr(i, 1) = brr(1, k - 6)
crr(i, 2) = brr(2, k - 6)
crr(i, 3) = brr(3, k - 6)
crr(i, 4) = brr(4, k - 6)
End If
crr(i, 5) = arr(i, 2)
crr(i, 6) = arr(i, 5)
crr(i, 7) = arr(i, k)
If arr(i + 1, k) = 0 Then
k = k + 1
End If
Next
With Sheet2
.Range("a2").Resize(UBound(crr), 7).ClearContents
.Range("a2").Resize(UBound(crr), 7) = crr
End With
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub

复制代码

Sellby · 发表于 2013-10-16 14:37

Sub sellby()
Dim arr, brr, crr(1 To 6000, 1 To 7)
Dim i&, j&, x&, y&, n&, t
Dim sh As Worksheet
t = Timer
Set sh = ThisWorkbook.Sheets("数据源")
arr = sh.Range("g1").CurrentRegion
x = 0: y = 0: n = 9
For i = 7 To UBound(arr, 2)
x = x + 1
crr(x, 1) = arr(3, i)
crr(x, 2) = arr(4, i)
crr(x, 3) = arr(5, i)
crr(x, 4) = arr(6, i)
For j = 10 To UBound(arr)
If arr(j, i) > 0 Then
crr(x + y, 5) = arr(j, 2)
crr(x + y, 6) = arr(j, 5)
crr(x + y, 7) = arr(j, i)
y = y + 1
ElseIf arr(j, i) = 0 And j > n Then
Exit For
End If
Next j
n = n + x + y: x = x + y - 1: y = 0
Next i
With Sheets("练习结果")
.Cells.ClearContents
.Range("a2").Resize(x, 7) = crr
End With
MsgBox Timer - t
End Sub

复制代码

fffox · 发表于 2013-10-16 15:34

请老师看一下，我的电脑比较破

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

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

评分

点评

点评

评分

点评

评分

点评

评分

点评

评分

点评

评分

点评

评分

点评

评分

点评

评分