ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2021函数公式学习大典 Excel数据透视表实战秘技 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
用ChatGPT与VBA一键搞定Excel WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 2535|回复: 11

[讨论] 五子棋:把横、竖、斜最长连续的数字1显示为红色

[复制链接]

TA的精华主题

TA的得分主题

发表于 2019-1-22 14:23 | 显示全部楼层 |阅读模式
本帖最后由 dsmch 于 2019-1-22 14:38 编辑


把棋盘上(绿色区域)最长连续摆放棋子(数字1)显示为红色。按五子棋的规则,即横、竖、斜方向。棋子用数字1表示,棋子摆放可能变化。

原贴:http://club.excelhome.net/forum.php?mod=viewthread&tid=167397&extra=page%3D1%26filter%3Dtypeid%26typeid%3D102

五子棋.rar

16.66 KB, 下载次数: 17

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-22 14:28 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
我先来段代码抛砖引玉
  1. Sub 五子棋()
  2. Set d = CreateObject("scripting.dictionary")
  3. arr = [c3:k11]
  4. [c3:k11].Font.ColorIndex = 0
  5. n1 = UBound(arr): n2 = UBound(arr, 2)
  6. For i = 1 To n1
  7.     For j = 1 To n2
  8.         If arr(i, j) = 1 Then
  9.             '行
  10.             s = 0
  11.             For k = j To n2
  12.                 If arr(i, k) = 1 Then s = s + 1
  13.                 If arr(i, k) <> 1 Then Exit For
  14.             Next
  15.             x = j - 1
  16.             If x > 0 Then
  17.                 For k = 1 To x
  18.                     If arr(i, j - k) = 1 Then s = s + 1
  19.                     If arr(i, j - k) <> 1 Then Exit For
  20.                 Next
  21.             End If
  22.             d(s) = d(s) & "," & Cells(i + 2, j + 2).Address
  23.             If n < s Then n = s
  24.             '列
  25.             s = 0
  26.             x = i - 1
  27.             If x > 0 Then
  28.                 For k = 1 To x
  29.                     If arr(i - k, j) = 1 Then s = s + 1
  30.                     If arr(i - k, j) <> 1 Then Exit For
  31.                 Next
  32.             End If
  33.             For k = i To n1
  34.                 If arr(k, j) = 1 Then s = s + 1
  35.                 If arr(k, j) <> 1 Then Exit For
  36.             Next
  37.             d(s) = d(s) & "," & Cells(i + 2, j + 2).Address
  38.             If n < s Then n = s
  39.             '右上左下
  40.             s = 0
  41.             x = Application.Min(i - 1, n2 - j)
  42.             If x > 0 Then
  43.                 For k = 1 To x
  44.                     If arr(i - k, j + k) = 1 Then s = s + 1
  45.                     If arr(i - k, j + k) <> 1 Then Exit For
  46.                 Next
  47.             End If
  48.             x = Application.Min(n1 - i, j - 1)
  49.             For k = 0 To x
  50.                 If arr(i + k, j - k) = 1 Then s = s + 1
  51.                 If arr(i + k, j - k) <> 1 Then Exit For
  52.             Next
  53.             d(s) = d(s) & "," & Cells(i + 2, j + 2).Address
  54.             If n < s Then n = s
  55.             '左上右下
  56.             s = 0
  57.             x = Application.Min(i - 1, j - 1)
  58.             If x > 0 Then
  59.                 For k = 1 To x
  60.                     If arr(i - k, j - k) = 1 Then s = s + 1
  61.                     If arr(i - k, j - k) <> 1 Then Exit For
  62.                 Next
  63.             End If
  64.             x = Application.Min(n1 - i, n2 - j)
  65.             For k = 0 To x
  66.                 If arr(i + k, j + k) = 1 Then s = s + 1
  67.                 If arr(i + k, j + k) <> 1 Then Exit For
  68.             Next
  69.             d(s) = d(s) & "," & Cells(i + 2, j + 2).Address
  70.             If n < s Then n = s
  71.         End If
  72.     Next
  73. Next
  74. y = Split(d(n), ",")
  75. For i = 1 To UBound(y)
  76.     Range(y(i)).Font.ColorIndex = 3
  77. Next
  78. End Sub
复制代码


五子棋.rar

16.66 KB, 下载次数: 6

TA的精华主题

TA的得分主题

发表于 2019-1-22 14:34 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2019-1-24 14:27 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
  1. Dim arr, rmax, cmax, s
  2. Sub test()
  3.     arr = Range("c3:k11")
  4.     rmax = UBound(arr): cmax = UBound(arr, 2)
  5.     For i = 1 To rmax - 1
  6.         For j = 1 To cmax - 1
  7.             If rmax - i + 1 >= nmax Or cmax - j + 1 >= nmax Then  '当横竖剩下格数比已知最大值大时才做判断
  8.                 If arr(i, j) = 1 Then
  9.                     n = check(i, j)
  10.                     If n = nmax Then ad = ad & "," & s
  11.                     If n > nmax Then nmax = n: ad = s
  12.                 End If
  13.             End If
  14.         Next
  15.     Next
  16.     [c3:k11].Font.Color = 0
  17.     Range(ad).Offset(2, 2).Font.Color = vbRed
  18.     MsgBox "连续摆放棋子的最大值是:" & nmax & Chr(10) & "位置是:" & Range(ad).Offset(2, 2).Address(0, 0)
  19. End Sub

  20. Function check(i, j)   '返回(i,j)开始连续摆放棋子的最大值,同时把地址放入s
  21.     s = Cells(i, j).Address(0, 0)
  22.     For nr = i + 1 To rmax
  23.         If arr(nr, j) = 1 Then adr = adr & "," & Cells(nr, j).Address(0, 0) Else Exit For
  24.     Next
  25.     For nc = j + 1 To cmax
  26.         If arr(i, nc) = 1 Then adc = adc & "," & Cells(i, nc).Address(0, 0) Else Exit For
  27.     Next
  28.     For k = 1 To rmax
  29.         If i + k > rmax Or j + k > cmax Then Exit For
  30.         If arr(i + k, j + k) = 1 Then adrc = adrc & "," & Cells(i + k, j + k).Address(0, 0) Else Exit For
  31.     Next
  32.     nn = Application.Max(nr - i, nc - j, k)
  33.     If nr - i >= nn Then s = s & adr
  34.     If nc - j >= nn Then s = s & adc
  35.     If k >= nn Then s = s & adrc
  36.     check = nn
  37. End Function
复制代码

五子棋.rar

23.17 KB, 下载次数: 6

评分

1

查看全部评分

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-24 14:37 | 显示全部楼层
多谢参与!这种情况代码结果有误

五子棋.rar

23.97 KB, 下载次数: 7

TA的精华主题

TA的得分主题

发表于 2019-1-24 18:07 | 显示全部楼层
有没有可能连续最多次数的结果同时有2个以上?是都高亮显示?还是只显示一种结果就行?写半天循环+if判断,最后模拟的时候才发现重复结果只能显示一个

TA的精华主题

TA的得分主题

 楼主| 发表于 2019-1-24 18:55 | 显示全部楼层
micch 发表于 2019-1-24 18:07
有没有可能连续最多次数的结果同时有2个以上?是都高亮显示?还是只显示一种结果就行?写半天循环+if判断, ...

同时高亮显示,主要是判断出最长的连续数字

TA的精华主题

TA的得分主题

发表于 2019-1-24 19:55 | 显示全部楼层
本帖最后由 micch 于 2019-1-24 20:57 编辑

重写一下,不考虑一个1都没有的情况
  1. Sub five()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     ar = [b2:l12]
  4.         For i = 2 To 10
  5.             For k = 2 To 10
  6.                 If ar(i, k) = 1 Then
  7.                     If ar(i, k - 1) <> 1 Then
  8.                         Do While ar(i, k + n) = 1 'right
  9.                             n = n + 1
  10.                             s = s & "," & Cells(i + 1, k + n).Address(0, 0)
  11.                         Loop
  12.                         d(n & "@" & Mid(s, 2)) = n: n = 0: s = ""
  13.                     End If
  14.                     If ar(i - 1, k - 1) <> 1 Then
  15.                         Do While ar(i + n, k + n) = 1 'rightdown
  16.                             n = n + 1
  17.                             s = s & "," & Cells(i + n, k + n).Address(0, 0)
  18.                         Loop
  19.                         d(n & "@" & Mid(s, 2)) = n: n = 0: s = ""
  20.                     End If
  21.                     If ar(i - 1, k) <> 1 Then
  22.                         Do While ar(i + n, k) = 1  'down
  23.                             n = n + 1
  24.                             s = s & "," & Cells(i + n, k + 1).Address(0, 0)
  25.                         Loop
  26.                         d(n & "@" & Mid(s, 2)) = n: n = 0: s = ""
  27.                     End If
  28.                     If ar(i - 1, k + 1) <> 1 Then
  29.                         Do While ar(i + n, k - n) = 1 'leftdown
  30.                             n = n + 1
  31.                             s = s & "," & Cells(i + n, k - n + 2).Address(0, 0)
  32.                         Loop
  33.                         d(n & "@" & Mid(s, 2)) = n: n = 0: s = ""
  34.                     End If
  35.                 End If
  36.         Next k, i
  37.     n = Application.Max(d.items)
  38.     ar = Filter(d.keys, n & "@")
  39.         For Each a In ar
  40.             Range(Split(a, "@")(1)).Font.ColorIndex = 3
  41.         Next
  42.     [n4] = n
  43. End Sub

复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-1-24 20:04 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
'没做起始点判断,效率差了一点,,,

Option Explicit

Dim max, cnt, list(1 To 100)

Sub test()
  Dim arr, i, j, k, pos, t
  pos = Array(1, 1, 1, 0, -1, 0, 1, 1) '左下、下、右下、左
  arr = [b2].Resize(11, 11)
  max = 0: cnt = 0
  For i = 2 To UBound(arr, 1) - 1
    For j = 2 To UBound(arr, 2) - 1
      If Len(arr(i, j)) Then
        For k = 0 To 3
          Call rec(arr, i, j, pos(k), pos(k + 4), 0, i & "," & j)
        Next
      End If
  Next j, i
  Cells.Font.Color = vbBlack
  If max > 0 Then
    For i = 1 To cnt
      t = Split(list(i), ",")
      For j = 0 To UBound(t) - 2 Step 2
        Cells(Val(t(j)) + 1, Val(t(j + 1)) + 1).Font.Color = vbRed
    Next j, i
  End If
End Sub

Function rec(arr, x, y, a, b, n, s)
  If Len(arr(x, y)) = 0 Then
    If max < n Then
      max = n: cnt = 1: list(cnt) = s
    ElseIf max = n Then
      cnt = cnt + 1: list(cnt) = s
    End If
  Else
    Call rec(arr, x + a, y + b, a, b, n + 1, s & "," & x + a & "," & y + b)
  End If
End Function

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2019-1-24 21:13 | 显示全部楼层
本帖最后由 micch 于 2019-1-24 21:18 编辑

有1存在,却没有任何两个1连续,最后所有的1都高亮显示,最大数为1;一个1都没有,最大数空
  1. Sub five()
  2.     Set d = CreateObject("scripting.dictionary")
  3.     [c3:k11].Font.ColorIndex = 1
  4.     [n4] = ""
  5.     ar = [b2:l12]
  6.         For i = 2 To 10
  7.             For k = 2 To 10
  8.                 If ar(i, k) = 1 Then
  9.                     If ar(i, k - 1) <> 1 Then
  10.                         Do While ar(i, k + n) = 1 'right
  11.                             n = n + 1
  12.                             s = s & "," & Cells(i + 1, k + n).Address(0, 0)
  13.                         Loop
  14.                         d(n & "@" & Mid(s, 2)) = n: n = 0: s = ""
  15.                     End If
  16.                     If ar(i - 1, k - 1) <> 1 Then
  17.                         Do While ar(i + n, k + n) = 1 'rightdown
  18.                             n = n + 1
  19.                             s = s & "," & Cells(i + n, k + n).Address(0, 0)
  20.                         Loop
  21.                         d(n & "@" & Mid(s, 2)) = n: n = 0: s = ""
  22.                     End If
  23.                     If ar(i - 1, k) <> 1 Then
  24.                         Do While ar(i + n, k) = 1  'down
  25.                             n = n + 1
  26.                             s = s & "," & Cells(i + n, k + 1).Address(0, 0)
  27.                         Loop
  28.                         d(n & "@" & Mid(s, 2)) = n: n = 0: s = ""
  29.                     End If
  30.                     If ar(i - 1, k + 1) <> 1 Then
  31.                         Do While ar(i + n, k - n) = 1 'leftdown
  32.                             n = n + 1
  33.                             s = s & "," & Cells(i + n, k - n + 2).Address(0, 0)
  34.                         Loop
  35.                         d(n & "@" & Mid(s, 2)) = n: n = 0: s = ""
  36.                     End If
  37.                 End If
  38.         Next k, i
  39.     If d.Count Then
  40.         n = Application.Max(d.items)
  41.         ar = Filter(d.keys, n & "@")
  42.             For Each a In ar
  43.                 Range(Split(a, "@")(1)).Font.ColorIndex = 3
  44.             Next
  45.         [n4] = n
  46.     End If
  47. End Sub
复制代码


评分

1

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-3-29 01:11 , Processed in 0.060341 second(s), 10 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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