[VBA接力赛第1期]真分数[已总结]

qee用 · 发表于 2007-3-18 22:41

截止3月18日22:30收到6份有效答案:bifengxia 3-13 21:55lpz001 3-16 19:58LJW17 3-17 23:03uranus1997 3-17 23:21戏子 3-18 8:44danielcm 3-18 22:27

danielcm · 发表于 2007-3-18 22:49

这是演示奖励2个金币

[此贴子已经被admin于2007-3-19 10:02:26编辑过]

qee用 · 发表于 2007-3-19 00:23

第1期VBA接力赛情况总述(一)这是前段时间在“编程爱好者”论坛看到的一道C语言题，本来是想考核大家排序算法的，发题时有些匆忙，既忽略了EXCEL自身的排序功能，更忘了EXCEL中的“分数”格式，真是惭愧。也好，EXCEL有EXCEL的精彩，感谢所有参与的朋友提供的精彩答案。因为排序已不是本题的重点，影响速度的主要因素就变成了两个方面： 1.数组的使用 VBA在对大数据的处理中，为了提高代码速度，数组是经常使用的方法。很多朋友对数组的方法可能还不熟悉，来看下面的例子： dim i& for i=1 to 10000   cells(i,2)=cells(i,1)*i next i 上面这段代码是将[A1]至[A10000]依次写入[A1]至[A10000]乘它们所在的行号，如果使用数组的方法，就是这样的： dim i&,arr1(),arr2(1 to 10000,1 to 1) arr1=range("A1:A10000") '将数据读入数组，当将超过1个单元格区域的数据读入Variant型变量时，便会产生一个下标从1开始的二维数组，两维分别对应行和列 for i=1 to 10000   arr2(i,1)=i*arr1(i,1) '从数组中读数计算比从工作表中读数快得多 next i range("B1:B10000")=arr2 '处理完成后，一次性写回工作表比逐个写快N倍 你只要记住上面注释的三行并学会应用，差不多就掌握了80%以上的数组知识。 2.最大公约数 Function Gys(ByVal a%, ByVal b%)   If a Mod b = 0 Then Gys = b: Exit Function   Gys = Gys(b, a Mod b) End Function 我不解释了，uranus1997在后面给了详尽的注释。 这道题所涉及的知识当然不限于上面两个方面，抛开因我的失误而埋没的排序算法，要验证最快速度，高级筛选、集合、SQL...差不多都有用武之地，有兴趣的朋友可以去尝试一下。

qee用 · 发表于 2007-3-19 00:26

VBA第1期接力赛情况总述(二)本次竞赛共收到bifengXia,plz001,LJW17,uranus1997,戏子,danielcm六位会员有效答案6份，正确性验证取N=2,6,100,200,300，速度评价取N=300。测试环境为Duron700/256M，WinXP+Excel2003。以下是参评代码（根据需要部分代码做了非实质性修改）及测试评价： '--*-- bifengXia --*-- Sub BiFengXia()     Dim i As Integer, j As Integer, k As Integer, t As Single, iNowRow As Integer     t = Timer     Range("A:A").Clear     k = Int(Range("B1").Value)     If k < 2 Then         MsgBox "在B1单元格输入一个大于等于 2 的整数！", , "BiFengXia"         Range("B1").Select         Exit Sub     End If     Application.ScreenUpdating = False     On Error GoTo 100     iNowRow = 1                 '当前行     For i = 1 To k              'i为分母         For j = 1 To i - 1      'j为分子,它的值在1到i-1之间,用自定义函数判断j与i是否能够组成真分数             If ProperFraction(j, i) Then                 Cells(iNowRow, 1).Value = "'" & j & "/" & i '如果是真分数,将分数写入A列                 Cells(iNowRow, 2).Value = j / i             '如果是真分数,将小数写入B列                 iNowRow = iNowRow + 1                       '下移一行             End If         Next j     Next i     '根据B列的临时值（小数）扩展排序，按升充排列     Range("A1:B" & iNowRow).Sort Key1:=Range("B1"), Order1:=xlAscending, Header:= _         xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _         SortMethod:=xlPinYin, DataOption1:=xlSortNormal     Range("B:B").Clear          '清楚B列的临时值     Range("B1").Select     Range("B1").Value = k     Application.ScreenUpdating = True     MsgBox "共用时：" & (Timer - t) * 1000 & "毫秒！", , "BiFengXia"     Exit Sub 100:     MsgBox "结果超出运算的最大行，产生了溢出！请最好将B1单元格的数值减小到320以内。", , "BiFengXia"     Range("A:B").Clear     Range("B1").Value = k     Range("B1").Select End Sub'自定义函数，测试是否为真分数（分子为number1，分母为number2）

rivate Function ProperFraction(number1 As Integer, number2 As Integer) As Boolean     ProperFraction = True     If number2 Mod number1 = 0 And number1 > 1 Then         '如果分子能够被分母整除，则不是真分数，返回结果         ProperFraction = False         Exit Function     End If     Dim k As Integer     'For k = 2 To (number1 + 2) / 2     For k = 2 To number1         If number1 Mod k = 0 And number2 Mod k = 0 Then     '如果分子与分母有公约数，则不是真分数，返回结果             ProperFraction = False             Exit Function         End If     Next k End Function ------ 结果：正确用时：26.29秒 代码结构清晰，书写规范。输出结果为文本格式，如修改为按分数形式输出，速度应当更快。'--*-- plz001 --*--

rivate Sub CommandButton1_Click()     Application.ScreenUpdating = False     M = Timer     Columns("A:A").ClearContents     Columns("A:A").NumberFormatLocal = "# ???/???"     v = Cells(1, 2)     If v = 2 Then [a1] = 0.5: Exit Sub     r = 0                 '在数组中生成分数列，速度快     ReDim arrl(1 To (v * (v - 1) / 2), 0)     For i = 2 To v         For t = 1 To i - 1             r = r + 1             arrl(r, 0) = t / i         Next t     Next i     Range("A1:A" & r) = arrl     Set arr = Range("a1:a" & r)   '对对象变量的操作比直接访问对象速度快     arr.Sort Key1:=arr(1, 1), Order1:=xlAscending, Header:=xlNo     rng1 = arr       '?????     ReDim ary(1 To r, 0)         '排序后再筛选，这样的算法快     ary(1, 0) = rng1(1, 1)     For i = 2 To r         If rng1(i, 1) <> rng1(i - 1, 1) Then             ary(k + 2, 0) = rng1(i, 1)             k = k + 1         End If     Next i     Range("A1:A" & r) = ary     Application.ScreenUpdating = True     MsgBox Timer - M End Sub ------ 结果：正确用时：1.48秒 精益求精，每一次都给我惊喜，能够在这么短时间内掌握数组的使用，除了天资聪颖，更可赞学习探索之精神可嘉。 “对对象变量的操作比直接访问对象速度快”我测试的结果没有得到证实。建议以后在书写代码时使用变量声明（Option Explicit），细节上如边缘数据，运行环境预清理等等要注意考虑，良好的代码习惯的会使进步更快。'--*-- LJW17 --*-- Sub zhengFS()     ' 从B1单元格读取一个任意整数,按从小到大顺序求出分子、分母均不大于该整数的真分数。     Dim n As Integer                             '读取整数存放的变量     Dim feimu() As Long                          '求出结果分母存放的数组     Dim feizi() As Long                          '求出结果分子存放的数组     Dim lp1, lp2                                 '循环变量     Dim gesu As Long                             '求出结果的个数     gesu = 0                                     '个数赋0     n = Cells(1, 2).Value                        '读出整数     ReDim feimu(CLng(n) * CLng(n - 1) / 2)       '根据n重新定义分母、分子数组的大小     ReDim feizi(CLng(n) * CLng(n - 1) / 2)       '因计算结果可能为Long型,为防止溢出错误,需要使用CLng转换函数     For lp1 = 2 To n                             '分母循环         For lp2 = 1 To lp1 - 1                   '分子循环             If lp2 = 1 Then                      '判断分子是否为1，是则肯定是真分数                gesu = gesu + 1                   '个数加1，并保存好分子、分母                feimu(gesu) = lp1                feizi(gesu) = lp2             Else                If zhengfeisu(lp2, lp1) Then      '判断是否为真分数，是则保存，否则不保存                   gesu = gesu + 1                   feimu(gesu) = lp1                   feizi(gesu) = lp2                End If             End If         Next lp2     Next lp1     For lp1 = 1 To gesu                          '通过冒泡排序，将求出的真分数存放的数组按小到大排序         feimu(0) = feimu(lp1)         feizi(0) = feizi(lp1)         For lp2 = lp1 + 1 To gesu                '求出一组数中的最小值，并将最小值移到前面             If feizi(0) / feimu(0) > feizi(lp2) / feimu(lp2) Then                feizi(lp1) = feizi(lp2)                feimu(lp1) = feimu(lp2)                feizi(lp2) = feizi(0)                feimu(lp2) = feimu(0)                feizi(0) = feizi(lp1)                feimu(0) = feimu(lp1)             End If         Next lp2     Next lp1     Range("a:a").Clear                           '清空A列     For lp1 = 1 To gesu                          '将求出并排好序的真分数写入A列中         Cells(lp1, 1).Value = "'" + CStr(feizi(lp1)) + "/" + CStr(feimu(lp1))     Next lp1 End SubFunction zhengfeisu(i, j) As Boolean ''****************************************************************************** ''**      判断分子为i，分母为j的分数是否真分数，是则还加True，否则还False     ** ''******************************************************************************     Dim lp3     zhengfeisu = True                               '假设该数是真分数     If j / i <> j \ i Then                          '判断分母、分子是否能够整除        For lp3 = 2 To i \ 2                         '不能整除则循环求出分子、分母是否存在公约数            If i Mod lp3 = 0 And j Mod lp3 = 0 Then               zhengfeisu = False                    '存在公约数则不是真分数               Exit For            End If        Next lp3     Else        zhengfeisu = False                           '如果分母、分子能够整除则不是真分数     End If End Function ------ 结果：正确用时：596秒 结构清晰规范，详尽的注释很难得，冒泡排序对大数据的处理效率很低。

qee用 · 发表于 2007-3-19 00:27

'--*-- uranus1997 --*--

rivate Sub CommandButton1_Click() Dim x As Integer Dim y As Integer Dim t As Singlet = Timer Application.ScreenUpdating = False Sheets(1).[A:A].ClearContents ThisWorkbook.SaveIf Sheets(1).[B1].Value = 1 Then     MsgBox "没有符合的分数"     Exit Sub End IfDim yMax As Integer yMax = Sheets(1).[B1].Value Dim NowPos As Integer NowPos = 1 For y = 2 To yMax Cells(NowPos, 1) = 1 / y NowPos = NowPos + 1     If y <> 2 Then     Cells(NowPos, 1) = (y - 1) / y     NowPos = NowPos + 1     End If         For x = 1 To yMax - 1             If x < y And x <> 1 And y - x <> 1 Then                 If x Mod 2 <> 0 Or y Mod 2 <> 0 Then                     If gcd(y, x) = 1 Then                     Cells(NowPos, 1) = x / y                     NowPos = NowPos + 1                     End If                 End If             End If         Next x Next ySheets(1).[A:A].Sort Key1:=Range("A1"), Orientation:=xlTopToBottom MsgBox "用时" & Format(Timer - t, "0.00") & "秒" Application.ScreenUpdating = True End SubFunction gcd(ByVal m As Integer, ByVal n As Integer) As Integer   Do While n <> 0     reminder = m Mod n     m = n     n = reminder   Loop   gcd = m End Function ------ 结果：正确用时：6.27秒 忽略了必要注释要求。构思严谨，结构清晰规范，公约数函数更是可圈可点，如果使用数组，速度将大为提高。 '--*-- 戏子 --*-- Sub sanbe1() Application.ScreenUpdating = False On Error Resume Next t = Timer n = [b1] Dim arr(1 To 32768, 1 To 1) Range("A1:A" & [A65536].End(xlUp).Row).ClearContents m = 1 For i = 1 To n     For j = 1 To i - 1         arr(m, 1) = j / i                 m = m + 1     Next j Next i [a1:a32768] = arrFor i = 1 To [A65536].End(xlUp).Row     j = Application.WorksheetFunction.CountIf(Range("A1:A" & [A65536].End(xlUp).Row), Cells(i, 1)) - 1     For m = 1 To j         row1 = Application.WorksheetFunction.Match(Cells(i, 1), Range(Cells(i + 1, 1), Cells([A65536].End(xlUp).Row, 1)), 0)         Cells(row1 + i, 1).ClearContents     Next Next '//A列按升序排列     Range("A1:A" & [A65536].End(xlUp).Row).Select     Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _         :=xlPinYin, DataOption1:=xlSortTextAsNumbers tim = (Timer - t) * 1000 MsgBox "共耗时:" & tim & "毫秒" Application.ScreenUpdating = True End Sub------ 结果：正确用时：485秒 使用工作表函数筛选不重复值，构思特别。但CountIf是公认最慢的工作表函数之一。'--*-- danielcm --*-- Dim AisFS As Boolean

rivate Sub CommandButton1_Click()  Dim A As Single, k As Integer, i As Integer, i1 As Integer, m As Integer, B As Integer  Dim arr() As String     Application.ScreenUpdating = False     A = Timer                                                   '记时开始     Columns("A:A").ClearContents     Sheets(1).Columns(1).NumberFormatLocal = "# ?/???"          '定义A列格式  ReDim Preserve arr(1 To 27400)                                 '分配数组存储空间     k = [b1]                                                    '取B1最大分母值  For i = 1 To k - 1                                             '分子     For i1 = i + 1 To k                                         '分母         B = i         AisFS = False         SigeFS i, i1, B         If AisFS = False Then             m = m + 1             arr(m) = CStr(i) & "/" & CStr(i1)                   '数据存入数组         End If     Next i1 Next i     Range("A1").Resize(m, 1) = Application.WorksheetFunction.Transpose(arr)     '将数组填充到表     Range("A1:A" & m).Select                                                    '选择     Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:=xlGuess, _         OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod _         :=xlPinYin, DataOption1:=xlSortNormal                                   '排序     Application.ScreenUpdating = True     MsgBox "总用时 " & Format(Timer - A, "0.000") & "秒。"                      '统计时间 End Sub Function SigeFS(ByVal Fz As Integer, ByVal Fm As Integer, moDnum As Integer) '进行递归 If moDnum = 1 Then Exit Function If (Fz Mod moDnum) = 0 And (Fm Mod moDnum) = 0 Then     AisFS = True: Exit Function Else     moDnum = moDnum - 1     SigeFS Fz, Fm, moDnum End If End Function ------ 结果：正确用时：8.25秒 代码结构清晰，简洁规范。 **********************************

qee用 · 发表于 2007-3-19 00:29

VBA第1期接力赛情况总述(三)根据以上测评，现公布第1期VBA接力赛评定结果如下： 1.bifengXia,LJW17,戏子,danielcm获参与奖，每人奖励2个金币。 2.uranus1997获参与奖，奖励3个金币。 3.本期优胜者为plz001,奖励8个金币，并负责组织下期VBA接力赛。最后，再次对所有参与者表示感谢，对获奖者和优胜者表示祝贺！ 参见:VBA接力赛规则（试行）

uranus1997 · 发表于 2007-3-19 03:21

<div class="msgheader">QUOTE:</div><div class="msgborder">以下是引用qee用在2007-3-19 0:23:13的发言： 第1期VBA接力赛情况总述(一)这是前段时间在“编程爱好者”论坛看到的一道C语言题，本来是想考核大家排序算法的，发题时有些匆忙，既忽略了EXCEL自身的排序功能，更忘了EXCEL中的“分数”格式，真是惭愧。也好，EXCEL有EXCEL的精彩，感谢所有参与的朋友提供的精彩答案。因为排序已不是本题的重点，影响速度的主要因素就变成了两个方面： 1.数组的使用 VBA在对大数据的处理中，为了提高代码速度，数组是经常使用的方法。很多朋友对数组的方法可能还不熟悉，来看下面的例子： dim i& for i=1 to 10000   cells(i,2)=cells(i,1)*i next i 上面这段代码是将[A1]至[A10000]依次写入[A1]至[A10000]乘它们所在的行号，如果使用数组的方法，就是这样的： dim i&,arr1(),arr2(1 to 10000,1 to 1) arr1=range("A1:A10000") '将数据读入数组，当将超过1个单元格区域的数据读入Variant型变量时，便会产生一个下标从1开始的二维数组，两维分别对应行和列 for i=1 to 10000   arr2(i,1)=i*arr1(i,1) '从数组中读数计算比从工作表中读数快得多 next i range("B1:B10000")=arr2 '处理完成后，一次性写回工作表比逐个写快N倍 你只要记住上面注释的三行并学会应用，差不多就掌握了80%以上的数组知识。 2.最大公约数 Function Gys(ByVal a%, ByVal b%)   If a Mod b = 0 Then Gys = b: Exit Function   Gys = Gys(b, a Mod b) End Function 我不解释了，uranus1997在后面给了详尽的注释。 这道题所涉及的知识当然不限于上面两个方面，抛开因我的失误而埋没的排序算法，要验证最快速度，高级筛选、集合、SQL...差不多都有用武之地，有兴趣的朋友可以去尝试一下。</div>之前就知道用数组可以提速的, 偏偏就是卡在数组的运用上了, 现在经Q版一点, 开窍了: )

S: 第一次上交的答案是有注解的, 第二次忘记加上了, 既然Q版提到, 就补一下最大公约数的注解. 辗转相除法定理: 设a,b,c是任意三个不全为0的整数，且a=bq+c 其中q是整数，则a,b与b,c有相同的公约数，即(a,b)=(b,c). 转化为公式就是gcd(a,b) = gcd(b,a mod b)←递归...... 不太喜欢......[em04]Function gcd(ByVal m As Integer, ByVal n As Integer) As Integer   '求最大公约数公式----辗转相除法(欧几里德算法) Do While n <> 0              '当n大于0时, 循环继续     reminder = m Mod n    '先用小的一个数n除大的一个数m，得第一个余数reminder     m = n                           '把n作为被除数     n = reminder                '把reminder作为除数 Loop                                '循环,     gcd = m                       '当余数为0时(赋值给n了, 即n=0), 循环结束, 最大公约数gcd为最后一个除数n(赋值给m了) End Function题外话: 发觉想学好编程, 数学必须要过关......我得恶补一下数学了...... 奖励3个金币

[此贴子已经被qee用于2007-3-19 10:39:59编辑过]

bifengxia · 发表于 2007-3-19 10:28

Q版的代码,真是强.学习了![em04][em04]

ljw17 · 发表于 2007-3-19 10:53

精彩，太精彩！努力努力再努力！ 奖励2个金币

[此贴子已经被admin于2007-3-19 11:01:05编辑过]

qee用 · 发表于 2007-3-19 11:05

全部奖金发放完毕[em24][em24][em24][em24][em24][em24]

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