[竟赛题]十进制递增输入（已结贴）

戏子 · 发表于 2007-4-24 00:41

（图1<img src="data/attachment/forum/dvbbs/2007-4/20074240442341132.bmp" border="0" onclick="zoom(this)" onload="if(this.width>document.body.clientWidth*0.5) {this.resized=true;this.width=document.body.clientWidth*0.5;this.style.cursor='pointer';} else {this.onclick=null}" alt="" />  图2<img src="data/attachment/forum/dvbbs/2007-4/20074240445617953.bmp" border="0" onclick="zoom(this)" onload="if(this.width>document.body.clientWidth*0.5) {this.resized=true;this.width=document.body.clientWidth*0.5;this.style.cursor='pointer';} else {this.onclick=null}" alt="" />图3<img src="data/attachment/forum/dvbbs/2007-4/20074240452434389.bmp" border="0" onclick="zoom(this)" onload="if(this.width>document.body.clientWidth*0.5) {this.resized=true;this.width=document.body.clientWidth*0.5;this.style.cursor='pointer';} else {this.onclick=null}" alt="" />图4<img src="data/attachment/forum/dvbbs/2007-4/20074240454167955.bmp" border="0" onclick="zoom(this)" onload="if(this.width>document.body.clientWidth*0.5) {this.resized=true;this.width=document.body.clientWidth*0.5;this.style.cursor='pointer';} else {this.onclick=null}" alt="" />题目要求：1、VBA代码自动录入，如图1所示，从000开始到999结束，如图4所示2、每张工作表限制200行，如图2所示3、自动新建工作表，并接上表连续输入，如图3所示 评比标准：结果正确情况下速度为评比第一要素，要求测试设置时间为毫秒，测试机器会采用同一台机器统一测试参赛资格：六段及以下会员4月30日24：00前提交答案并结果正确奖罚制度：1、奖励前三名奖金分别为5、3、2个金币2、不得以马甲参赛，违者封ID并罚50金币3、其它高段及版主参与另设奖励4、答案必须上交到指定地点，否则无效答案上传处：<a href="http://www.excelpx.com/forum.php?mod=viewthread&tid=16224">http://www.excelpx.com/forum.php?mod=viewthread&tid=16224</a>

[此贴子已经被作者于2007-5-1 10:10:26编辑过]

烟雨江南 · 发表于 2007-4-24 08:43

先占个位，嘿嘿

bifengxia · 发表于 2007-4-24 10:08

占个板凳先.[em01][em01][em01]

戏子 · 发表于 2007-4-25 17:25

截止2007年4月29日24:00上交有效答案MXQCHINAjonnniLuckyguy2008djyjysxxslpz001

[此贴子已经被作者于2007-4-30 10:02:15编辑过]

jiuping · 发表于 2007-4-29 20:30

好像不是太难。

戏子 · 发表于 2007-5-1 10:13

本次竞赛正如element兄和qee用兄所说数据量比较少，算法上几乎没有时间差距程序耗费的时间主要还是在如何向工作表写数据写入工作表的方法上也没有多大的区别这是我所没考虑到的的，第一次搞竞赛有什么不到之处还请大家谅解测试机器：P4D 3.0G，512M DDR667 本次优胜者：Luckyguy2008（奖五个金币）、mxqchina2（三个金币）其他参与者各二个金币版主们让管理员给点参与奖吧

[此贴子已经被作者于2007-5-1 10:53:09编辑过]

戏子 · 发表于 2007-5-1 10:14

飞雨飘版主提供了最原始的解法，这也是我初学VBA时用的方法 Sub AA() Dim M, N, J, K, L As Integer K = 1 L = 1 For M = 0 To 9    For N = O To 9       For J = 0 To 9          Sheets(L).Cells(K, 1) = M          Sheets(L).Cells(K, 2) = N          Sheets(L).Cells(K, 3) = J          K = K + 1       Next    Next    If M Mod 2 <> 0 Then       L = L + 1          If L > 3 Then Sheets.Add , Sheets(L - 1)       K = 1    End IfNext End Sub 我们公认为速度最慢的一种方法512.625毫秒,PS:可惜被笔锋侠版主给打破了[em07][em07]

戏子 · 发表于 2007-5-1 10:14

笔锋侠版主提供五种方法 Sub 方法一()     Dim i As Integer, j As Integer, t As Single, arr() As Integer     t = Timer     Application.ScreenUpdating = False         j = Int(1000 / 200) - Sheets.Count     If j > 0 Then         For i = 1 To j             ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)         Next i     End If     ReDim arr(1 To Int(1000 / 200), 1 To 200, 1 To 3)     For i = 0 To 999         arr(Int(i / 200) + 1, (i Mod 200) + 1, 1) = Int(i / 100)         arr(Int(i / 200) + 1, (i Mod 200) + 1, 2) = Int(i / 10) Mod 10         arr(Int(i / 200) + 1, (i Mod 200) + 1, 3) = i Mod 10     Next i         For i = 1 To Int(1000 / 200)         For j = 1 To 200             Sheets(i).Range("A" & j) = arr(i, j, 1)             Sheets(i).Range("B" & j) = arr(i, j, 2)             Sheets(i).Range("C" & j) = arr(i, j, 3)         Next j     Next i     Sheets(1).Select     Range("F1") = (Timer - t) * 1000     MsgBox "共用时：" & (Timer - t) * 1000 & "毫秒" End Sub 耗时453毫秒 Sub 方法二()     Dim i As Integer, j As Integer, t As Single, arr() As Integer     Dim cn As New ADODB.Connection, sql As String     t = Timer     Application.ScreenUpdating = False     j = Int(1000 / 200) - Sheets.Count     If j > 0 Then         For i = 1 To j             ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)         Next i     End If     ReDim arr(1 To 1000, 1 To 4)     For i = 1 To 1000         j = i - 1         arr(i, 1) = Int(j / 100)         arr(i, 2) = Int(j / 10) Mod 10         arr(i, 3) = j Mod 10         arr(i, 4) = Int(j / 200) + 1     Next i     With Sheets(1)         .Range("A1") = "A"         .Range("B1") = "B"         .Range("C1") = "C"         .Range("D1") = "D"         .Range("A2:D1001") = arr()     End With         cn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName     For i = Int(1000 / 200) To 1 Step -1         sql = "select A,B,C from [sheet1$] where D = " & i         Sheets(i).Range("A1").CopyFromRecordset cn.Execute(sql)     Next i     cn.Close     Set cn = Nothing         Sheets(1).Select     Range("A201:D1000").ClearContents     Range("D1:D200").ClearContents     Range("F2") = (Timer - t) * 1000     MsgBox "共用时：" & (Timer - t) * 1000 & "毫秒" End Sub 数组+SQL的方法，因为数据量大小没有发挥出优势，耗时421.375毫秒 Sub 方法三()     Dim i As Integer, j As Integer, t As Single     t = Timer     Application.ScreenUpdating = False         j = Int(1000 / 200) - Sheets.Count     If j > 0 Then         For i = 1 To j             ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)         Next i     End If         For i = 0 To 999         j = Int(i / 200) + 1         With Sheets(j)             .Range("A" & (i Mod 200) + 1) = Int(i / 100)             .Range("B" & (i Mod 200) + 1) = Int(i / 10) Mod 10             .Range("C" & (i Mod 200) + 1) = i Mod 10         End With     Next i     Sheets(1).Select     Range("F3") = (Timer - t) * 1000     MsgBox "共用时：" & (Timer - t) * 1000 & "毫秒" End Sub 这种方法居然打破了原始方法的最慢记录，耗时1124毫秒，PS：如果评最慢速度这个代码估计第一了[em01][em01] Sub 方法四()     Dim i As Integer, j As Integer, t As Single, arr1(1 To 1000, 1 To 3) As Integer, arr2(1 To 200, 1 To 3) As Integer         t = Timer     Application.ScreenUpdating = False Worksheets.Count     j = Int(1000 / 200) - Sheets.Count     If j > 0 Then         For i = 1 To j             ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)         Next i     End If    For i = 1 To 1000         j = i - 1         arr1(i, 1) = Int(j / 100)         arr1(i, 2) = Int(j / 10) Mod 10         arr1(i, 3) = j Mod 10     Next i         For j = 1000 / 200 - 1 To 0 Step -1         For i = 1 To 200             arr2(i, 1) = arr1(200 * j + i, 1)             arr2(i, 2) = arr1(200 * j + i, 2)             arr2(i, 3) = arr1(200 * j + i, 3)         Next i         Sheets(j + 1).Range("A1:C200") = arr2()     Next j     Sheets(1).Select     Range("F4") = (Timer - t) * 1000     MsgBox "共用时：" & Range("F4").Value & "毫秒" End Sub 耗时15.5毫秒 Sub 方法五()     Dim i As Integer, j As Integer, t As Single, arr1(1 To 1000, 1 To 3) As Integer     t = Timer     Application.ScreenUpdating = False     j = Int(1000 / 200) - Sheets.Count     If j > 0 Then         For i = 1 To j             ActiveWorkbook.Sheets.Add After:=Worksheets(Worksheets.Count)         Next i     End If    For i = 1 To 200         j = i - 1         arr1(i, 1) = Int(j / 100)         arr1(i, 2) = Int(j / 10) Mod 10         arr1(i, 3) = j Mod 10     Next i         For j = 1 To 1000 / 200         Sheets(j).Range("A1:C200") = arr1()         For i = 1 To 200             arr1(i, 1) = arr1(i, 1) + 2         Next i     Next j     Sheets(1).Select     Range("F5") = (Timer - t) * 1000     MsgBox "共用时：" & Range("F5").Value & "毫秒" End Sub 耗时15.125毫秒（本次竞赛最快记录）

[此贴子已经被作者于2007-5-1 10:20:58编辑过]

戏子 · 发表于 2007-5-1 10:15

element版主的代码如下： Sub element()     Dim arr() As Integer     Dim i As Integer     Dim j As Integer     Dim m As Integer     Dim iCnt As Integer     Dim oSht As Worksheet     Dim mTime As Single         Application.ScreenUpdating = False     mTime = Timer     Set oSht = ActiveSheet     iCnt = Int(1000 / 200)     For i = 1 To iCnt - 1         Sheets.Add After:=Sheets(Sheets.Count)     Next     For i = 1 To iCnt         ReDim arr(1 To 200, 1 To 3)         For j = 1 To 200             m = m + 1             arr(j, 1) = Int((m - 1) / 100)             arr(j, 2) = Int(Right(j - 1, 2) / 10)             arr(j, 3) = (j - 1) Mod 10         Next         Sheets(i).Range("A1:C200") = arr     Next     oSht.Activate     MsgBox (Timer - mTime) * 1000     Application.ScreenUpdating = True End Sub 耗时16.625毫秒

[此贴子已经被作者于2007-5-1 10:22:25编辑过]

戏子 · 发表于 2007-5-1 10:15

qee用版主： Sub atest()   Dim i%, j%, k%, l%   Dim sh As Worksheet   Dim s(1 To 200, 1 To 2)   Dim rg As Range   Dim t   t = Timer   Application.ScreenUpdating = False   Set sh = Sheet1   l = 1   For i = 1 To 2     For j = 0 To 9       For k = 0 To 9        s(l, 1) = j        s(l, 2) = k        l = l + 1      Next k    Next j  Next i  For i = 0 To 8 Step 2    With sh      .Range("A:C").ColumnWidth = 3      .Range("B1:C200") = s      .Range("A1:A100") = i      .Range("A101:A200") = i + 1    End With    If i < 8 Then Set sh = Worksheets.Add(after:=sh)  Next i  Sheet1.Select  Application.ScreenUpdating = True  MsgBox (Timer - t) * 1000 & "ms" End Sub 耗时46.875毫秒

[此贴子已经被作者于2007-5-1 10:21:59编辑过]

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

[竟赛题]十进制递增输入（已结贴）

浏览过的版块