设为首页收藏本站
简字体切换切换到宽版

ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步，快速开始

快捷登录

搜索
ExcelHome技术论坛»论坛 › Excel 技术交流与问答 › Excel VBA程序开发 › 单循环比赛赛程安排排定
EH技术汇-专业的职场技能充电站 妙哉！函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 效率神器，一键搞定繁琐工作
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
让更多数据处理，一键完成 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
返回列表 发新帖
查看: 6468|回复: 7

[分享] 单循环比赛赛程安排排定

[复制链接]
yangyangzhifeng

TA的精华主题

TA的得分主题
发表于 2012-12-22 20:54 | 显示全部楼层 |阅读模式
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册★
本帖已被收录到知识树中，索引项：其他结构和算法
本帖最后由 yangyangzhifeng 于 2013-2-9 10:53 编辑

在论坛大概搜索了一下，好像还没有完整的讨论，算是抛砖引玉吧
单循环比赛对阵.rar (14.42 KB, 下载次数: 580) 包含两种方法

  1. Sub gdlh() '固定轮换法
  2.     Dim ar, i&, j&, x&, n&, lunci&, y&, t&
  3.     Dim br, k
  4.     Const duishu = 15
  5.     If duishu Mod 2 = 0 Then
  6.         n = duishu / 2: lunci = duishu - 1: t = duishu
  7.     Else
  8.         n = (duishu + 1) / 2: lunci = duishu: t = 0
  9.     End If
  10.     ReDim ar(1 To n, 1 To 2): ReDim br(1 To lunci, 1 To n)
  11.     ar(1, 1) = 1
  12.     For i = 1 To lunci
  13.         x = x + 1: x = IIf(x > 2 * n, 2, x)
  14.         y = x
  15.         For j = 2 To 2 * n
  16.             y = y + 1
  17.             If y > 2 * n Then y = 2
  18.             ar(r(y, n), c(y, n)) = IIf(j = 2 * n, t, j)
  19.         Next
  20.         For k = 1 To UBound(ar)
  21.             br(i, k) = Format(ar(k, 1), "000") & "_" & Format(ar(k, 2), "000")
  22.         Next
  23.     Next
  24.     Sheet1.Cells.ClearContents
  25.     Sheet1.[a1].Resize(lunci, n).Columns.AutoFit
  26.     Sheet1.[a1].Resize(lunci, n) = br
  27. End Sub
  28. Function r(ByVal x As Long, n&)
  29.     x = IIf(x <= n, x, 3 * n - x + 1)
  30.     r = 1 + ((x - 1) Mod n)
  31. End Function
  32. Function c(ByVal x As Long, n&)
  33.     x = IIf(x <= n, x, 3 * n - x + 1)
  34.     c = (x - 1) \ n + 1
  35. End Function
复制代码

单循环, 循环, 循环比, 比赛, 赛程

评分

2

查看全部评分

回复

举报

yangyangzhifeng

TA的精华主题

TA的得分主题
 楼主| 发表于 2012-12-22 23:21 | 显示全部楼层
[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★
上面是固定轮换法，下面再提供一个贝格尔编排法

  2. Sub berger()
  3.     Dim ar, i&, j&, x&, n&, lunci&, jg&, y&, t&
  4.     Dim br, k
  5.     Const duishu = 16
  6.     If duishu Mod 2 = 0 Then
  7.         n = duishu / 2: lunci = duishu - 1: t = duishu
  8.     Else
  9.         n = (duishu + 1) / 2: lunci = duishu: t = 0
  10.     End If
  11.     ReDim ar(1 To n, 1 To 2): ReDim br(1 To lunci, 1 To n)
  12.     If duishu <= 4 Then jg = 1 Else jg = n - 1
  13.     x = 1
  14.     For i = 1 To lunci
  15.         y = x - 1
  16.         For j = 1 To 2 * n - 1
  17.             y = y + 1
  18.             If y > 2 * n Then y = 2
  19.             ar(r(y, n), c(y, n)) = j
  20.             If y = 2 * n And i Mod 2 = 1 Then ar(1, 1) = ar(1, 2)
  21.         Next
  22.         If i Mod 2 = 1 Then ar(1, 2) = t Else ar(1, 1) = t
  23.         For k = 1 To UBound(ar)
  24.             br(i, k) = Format(ar(k, 1), "000") & "_" & Format(ar(k, 2), "000")
  25.         Next
  26.         x = x + jg: x = IIf(x >= 2 * n, x + 1, x): x = ((x - 1) Mod 2 * n) + 1
  27.     Next
  28.     Sheet1.Cells.ClearContents
  29.     Sheet1.[a1].Resize(lunci, n).Columns.AutoFit
  30.     Sheet1.[a1].Resize(lunci, n) = br
  31. End Sub

  33. Function r(ByVal x As Long, n&)
  34.     x = IIf(x <= n, x, 3 * n - x + 1)
  35.     r = 1 + ((x - 1) Mod n)
  36. End Function
  37. Function c(ByVal x As Long, n&)
  38.     x = IIf(x <= n, x, 3 * n - x + 1)
  39.     c = (x - 1) \ n + 1
  40. End Function
复制代码

评分

1

查看全部评分

回复

举报

123233513

TA的精华主题

TA的得分主题
发表于 2012-12-23 08:29 | 显示全部楼层
[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★
{:soso_e179:}老师厉害！~~~~~~学习了。。。
回复

举报

刘志文

TA的精华主题

TA的得分主题
发表于 2012-12-25 23:16 | 显示全部楼层
[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★
谢谢分享,学习了
回复

举报

babol

TA的精华主题

TA的得分主题
发表于 2013-5-4 22:53 | 显示全部楼层
[广告] ★ 对Excel用户最友好的数据分析编程语言，再不发愁Excel计算困难和容量限制 ★
正需要，感谢。只是不知道那种方法更科学？应该都差不多吧？
回复

举报

wwwconsumer

TA的精华主题

TA的得分主题
发表于 2013-5-31 08:37 | 显示全部楼层
[广告] ★用Excel做企业管理系统，Excel服务器学习和下载★
楼主厉害，真的高手。
回复

举报

ddgod

TA的精华主题

TA的得分主题
发表于 2019-2-28 10:44 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助★
进来学习学习
回复

举报

ecwj

TA的精华主题

TA的得分主题
发表于 2020-9-8 22:03 | 显示全部楼层
[广告] ★会Excel,就能做支持PC、手机、Web、App、Windows、安卓、IOS、Linux信息一体化的各种管理系统 ★
修改了一下，这下看起来顺眼不少
  1. Sub berger()
  2.     Dim ar, i&, j&, x&, n&, lunci&, jg&, y&, t&
  3.     Dim br, k, duishu&
  4.     duishu = InputBox("请输入参赛对数", "对数")
  5.     If duishu Mod 2 = 0 Then
  6.         n = duishu / 2: lunci = duishu - 1: t = duishu
  7.     Else
  8.         n = (duishu + 1) / 2: lunci = duishu: t = 0
  9.     End If
  10.     ReDim ar(1 To n, 1 To 2): ReDim br(1 To lunci, 1 To n)
  11.     If duishu <= 4 Then jg = 1 Else jg = n - 1
  12.     x = 1
  13.     For i = 1 To lunci
  14.         y = x - 1
  15.         For j = 1 To 2 * n - 1
  16.             y = y + 1
  17.             If y > 2 * n Then y = 2
  18.             ar(r(y, n), c(y, n)) = j
  19.             If y = 2 * n And i Mod 2 = 1 Then ar(1, 1) = ar(1, 2)
  20.         Next
  21.         If i Mod 2 = 1 Then ar(1, 2) = t Else ar(1, 1) = t
  22.         For k = 1 To UBound(ar)
  23.             br(i, k) = Format(ar(k, 1), "0") & "--" & Format(ar(k, 2), "0")
  24.         Next
  25.         x = x + jg: x = IIf(x >= 2 * n, x + 1, x): x = ((x - 1) Mod 2 * n) + 1
  26.     Next
  27.     Sheet1.Cells.ClearContents
  28.     Sheet1.[a1].Resize(lunci, n).Columns.AutoFit
  29.      Sheet1.[a1].Resize(n, lunci) = WorksheetFunction.Transpose(br)
  30. End Sub
复制代码
回复

举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-11-22 01:04 , Processed in 0.044438 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见，任何违反国家相关法律的言论，本站将协助国家相关部门追究发言者责任！     本站特聘法律顾问：李志群律师

快速回复 返回顶部 返回列表