[第62期]计算乒乓球排名。(分数统计表已出，请大家检查是否有误。)

jxrbz · 发表于 2010-7-29 11:22

原帖由 feipeng1 于 2010-7-29 09:33 发表

乒乓球规则是胜一场积2分 ,负一场积一分,弃权0分,被弃权方按比赛赛制(五局三胜/三局二胜/七局四胜)分别以3:0,2:0,4:0计算.

这次所有的公式都需要单无格内有数据时才能进行正确计算.倒是用if函数对单无格数据进 ...

==============================
按这种说法积分应该用函数先求出，我还是支持用补助列的方法，可以提高excel的运行速度，以实用为主。平时竞赛题提倡不用补助列，本人认为不实用，但他对提高函数水平很有帮助。

泓() · 发表于 2010-7-29 13:38

Sub aSort()
Dim r As Range, d As Object
a = Cells(1, 1).End(xlDown).Row - 1
ReDim jf(1 To a), fb(1 To a, 1 To 2), rr(1 To a, 1 To 2), tmp(1 To a)
Set d = CreateObject("scripting.dictionary")
For i = 1 To a
Set r = Cells(i + 1, 2).Resize(1, a)
f = 0: b0 = 0: b1 = 0
For Each c In r
If InStr(c, ":") Then
v0 = Val(Split(c, ":")(0)): v1 = Val(Split(c, ":")(1))
b0 = b0 + v0: b1 = b1 + v1
If v0 > v1 Then
f = f + 2
ElseIf v0 < v1 Then
f = f + 1
End If
End If
Next
jf(i) = f: fb(i, 2) = b0 / IIf(b1 = 0, 1, b1)
If Not d.exists(f) Then d(f) = i Else d(f) = d(f) & " " & i
Next
k = d.keys: t = d.items
For i = 0 To d.Count - 1
it = Split(t(i))
If UBound(it) > 0 Then
For y = 0 To UBound(it)
b0 = 0: b1 = 0
For x = 0 To UBound(it)
c = Cells(it(y) + 1, 1).Offset(0, it(x))
If InStr(c, ":") Then
b0 = b0 + Val(Split(c, ":")(0))
b1 = b1 + Val(Split(c, ":")(1))
End If
Next
fb(it(y), 1) = b0 / IIf(b1 = 0, 1, b1)
Next
End If
Next
For i = 1 To a
tmp(i) = jf(i) * 10000 + fb(i, 1) * 1
Next
St = bSort(tmp, False)
For i = 1 To a
tmp(i) = St(i) * 10000 + fb(i, 2) * 1
Next
St = bSort(tmp, True)
For i = 1 To a
rr(i, 1) = jf(i)
rr(i, 2) = St(i)
Next
Cells(2, a + 2).Resize(a, 2) = rr
set r=nothing
set d=nothing
End Sub
Private Function bSort(arry(), bl As Boolean)
ub = UBound(arry)
ReDim tmp(1 To ub), temp(1 To ub), t(1 To ub)
For i = 1 To ub
If bl = False Then
tmp(i) = WorksheetFunction.Small(arry, i)
Else
tmp(i) = WorksheetFunction.Large(arry, i)
End If
temp(i) = i
If i > 1 Then
If tmp(i) = tmp(i - 1) Then temp(i) = temp(i - 1)
End If
Next
For i = 1 To ub
n = WorksheetFunction.Match(arry(i), tmp, 0)
t(i) = temp(n)
Next
bSort = t
End Function
Private Sub Worksheet_Change(ByVal Target As Range)
a = Cells(1, 1).End(xlDown).Row
If Target.Row <= a And Target.Column <= a Then
If InStr(Target, ":") Then
Cells(Target.Column, Target.Row) = Split(Target, ":")(1) & ":" & Split(Target, ":")(0)
Call aSort
End If
End If
End Sub

复制代码

[ 本帖最后由泓() 于 2010-7-29 14:08 编辑 ]

泓() · 发表于 2010-7-29 18:27

如果说速度稍慢些主要慢在工作表函数排序上
而且我采用了2次排序（只有经过2次排序才是正确的答案）

如果 vba 又引用原本函数公式的那样做可快些
但我不那样做
因为应付这么些数据目前的代码足已

泓() · 发表于 2010-7-29 18:04

没有辅助列
VBA代码还可以的
速度是过得去的
喜不喜欢当然由你
权当练习谢谢提供题目

这题就是当作ExcelVBA竞赛题也要喘口气的

feipeng1 · 发表于 2010-7-29 17:43

原帖由 泓() 于 2010-7-29 13:38 发表

Sub aSort()
Dim r As Range, d As Object
a = Cells(1, 1).End(xlDown).Row - 1
ReDim jf(1 To a), fb(1 To a, 1 To 2), rr(1 To a, 1 To 2), tmp(1 To a)
Set d = CreateObject("scripting. ...

谢谢泓的程序.
刚试用过,程序速度占用Cpu过高,还有溢出堆栈空间.在复制数据时会出错.
Vba不太懂,这些天倒是天天泡在一些实例上慢慢研究.估计弄懂这个还需时日.
如果鸿兄有空还请完善下这个程序.权当练手.

另外可能在一张表格内小组可能会有四个或者更多小组,程序移植是否能顺下复制倒不清楚.
个人感觉代码有些长,有公式300多字符,如果用Vba更为冗长还不如直接用公式.

我的思路可能是这样,只对积分相同选手之间的胜率进行操作,而不作过多的参数,
对Vba纯属没基本,权当瞎扯.

feipeng1 · 发表于 2010-7-29 19:57

原帖由 泓() 于 2010-7-29 18:04 发表
没有辅助列
VBA代码还可以的
速度是过得去的
喜不喜欢当然由你
权当练习谢谢提供题目

这题就是当作ExcelVBA竞赛题也要喘口气的

谢谢,非喜欢不喜欢,能够帮忙的就是好同志.HOHO,欢迎到成都来作客.
我运行的时候出现过好几次错误,可能是检查或者要求的比较严.

泓() · 发表于 2010-7-29 20:06

胡闹
其实你一点都不懂VBA
复制时出错我明白在哪里
其它的不出一个问题
你说说还有错在哪里？

feipeng1 · 发表于 2010-7-29 20:46

原帖由 泓() 于 2010-7-29 20:06 发表
胡闹
其实你一点都不懂VBA
复制时出错我明白在哪里
其它的不出一个问题
你说说还有错在哪里？

我本来就不懂的呀. 删除时也会出错.还有次是出现溢出.我只是说说而已.
软件有Bug很正常的呀,有则过之,无则加冕.

你水平比我高,但我确实是在实际中确实会出现了这样的问题.

feipeng1 · 发表于 2010-7-29 20:49

泓() · 发表于 2010-7-29 22:53

当出现如上楼对话框时，单击调试

就可以发现出错在哪一句：这个很重要

在复制时出错在“If InStr(Target, ":") Then” 主要是在选择时并不在一个单元格，可以这样修改：
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub'加这句就行了
a = Cells(1, 1).End(xlDown).Row
If Target.Row <= a And Target.Column <= a Then
      If InStr(Target, ":") Then
         Cells(Target.Column, Target.Row) = Split(Target, ":")(1) & ":" & Split(Target, ":")(0)
         Call aSort
      End If
End If

End Sub

----------------------------------------------
VBA错误信息:堆栈空间溢出（错误 28）

堆栈是内存的一个工作区，会随着程序运行的需要而增长或缩小。此错误有以下的原因和解决方法：

有太多活动的Function、Sub或Property过程调用。
检查过程的嵌套是否太深，尤其是递归过程，即自己调用自己的过程。确保递归能终止，使用“调用”对话框来查看活动的过程 (在堆栈上)。

本地变量需要更多可用的本地变量空间。
试着在模块级别中声明某些变量。可以在静态过程，即在Property、Sub或Function关键字前加上Static，声明所有变量，或可以在过程内使用Static语句来声明各个Static变量。

有太多定长字符串。
定长字符串在过程中可快速访问，比可变长度字符串使用更多堆栈空间，因为字符串数据本身要放在堆栈上。可试着重新定义一些定长字符串成为变长字符串。当声明一变长字符串时，只有字符串描述符 (非数据本身) 会放在堆栈上。可以在没有堆栈空间的模块层次上定义字符串。在模块层次申明变量是缺省为Public，所以在模块上所有过程皆可见到字符串。

DoEvents函数调用的嵌套太多。
利用“调用”对话框，在堆栈上查看正在活动的过程。

代码引起了事件层叠。
所谓事件层叠就是引起一个事件，此事件会调用已在堆栈上的事件过程。事件层叠和不能中止的递归过程调用是相似的，但不太明显，因为是由 Visual Basic 所调用，而不是在代码中调用。使用“调用”对话框来查看那些正在活动的过程 (在堆栈上)。

显示“调用”对话框，在“调试”窗口中选取过程框右边的“调用”按钮或选择“调用”命令。详细信息，可选取有问题的项目，并按下 F1 （在Windows中）或HELP（在Macintosh中）键

修改了bSort 中的变量
Private Function bSort(arry, bl As Boolean)
ub = UBound(arry)
ReDim tmp2(1 To ub), temp(1 To ub), tt(1 To ub)
For i = 1 To ub
      If bl = False Then
         tmp2(i) = WorksheetFunction.Small(arry, i)
      Else
         tmp2(i) = WorksheetFunction.Large(arry, i)
      End If
      temp(i) = i
      If i > 1 Then
         If tmp2(i) = tmp2(i - 1) Then temp(i) = temp(i - 1)
      End If
Next
For i = 1 To ub
      n = WorksheetFunction.Match(arry(i), tmp2, 0)
      tt(i) = temp(n)
Next
bSort = tt
End Function

这样是否还有出现问题
---------------------------------------
另外本想做一个工作表中可以支持多组
因为你不太喜欢用VBA来计算
话语中并不尊重VBA

如果有需要的话当然可以继续如果需要的话

[ 本帖最后由泓() 于 2010-7-29 23:26 编辑 ]

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

[Excel 函数与公式] [第62期]计算乒乓球排名。(分数统计表已出，请大家检查是否有误。)

feipeng1 或许梦寐以求的效果我只是用VBA去实现她

本帖子中包含更多资源

本帖子中包含更多资源

[Excel 函数与公式] [第62期]计算乒乓球排名。(分数统计表已出，请大家检查是否有误。)

feipeng1 或许梦寐以求的效果 我只是用VBA去实现她

本帖子中包含更多资源

本帖子中包含更多资源

feipeng1 或许梦寐以求的效果我只是用VBA去实现她