ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

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

[Excel 程序开发] [第101期_2]单词接龙[已总结]

[复制链接]

TA的精华主题

TA的得分主题

发表于 2014-1-6 18:13 | 显示全部楼层 |阅读模式
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 delete_007 于 2014-3-10 12:34 编辑

竞赛日期:2014-1-8至2014-2-18

题目内容:

英语老师组织英语课外活动,让同学们用她给出的一些单词玩接龙游戏,接龙的规则是前一个单词的末尾字母要和后一个单词的首字母相同,每一个单词只能用一次,重复的单词要使用其个数次,能够使用全部给定单词连接的称为完成接龙。另,单个字母的首字母同尾字母。老师给每个同学发放了不同的单词表,但有的同学发现无论如何也不能完成接龙。
我们的工作就是帮助老师写一个代码,来判断给定的一组单词是否能完成接龙。

示例:
love excel home 这三个单词可以接龙,home -> excel -> love
hate excel home 这三个单词就不能完成接龙

题目将测试100组单词,每组一万到六万不等,所有单词均以小写字母构成。

答题要求:
  1. Public Function CheckLinkability() As Variable
  2.     Dim t#: t = Timer
  3.     On Error GoTo END_FUNC
  4.     Dim aRes(1 To 3)
  5.     Open ThisWorkbook.Path & "\单词接龙_测试数据.csv" For Input Access Read As #1
  6.     ' ......
  7. END_FUNC:
  8.     Close #1
  9.     aRes(1) = "" ' <- 你的论坛ID
  10.     aRes(2) = Timer - t
  11.     If Err Then Err.Clear: aRes(2) = -1: On Error GoTo 0
  12.     ' aRes(3) 为100个字母 T 或 F 的字符串,T 为能够接龙,F 为不能
  13.     CheckLinkability = aRes
  14. End Function
复制代码
所有其它外部的过程、函数、变量、常量、自定义数据类型等等,均必须设置为Private。

答题只接受代码的直接发贴,不接受附件。

测试数据 文件由附件代码自动生成。其结构如下:
1、第一行为测试的单词组的数量,自行调试代码时,可将组数设小一点,生成一个短一点的测试数据。
2、其后,每一行对应一个单词组。
3、一行中,有三个数据,第一个为该组单词的单词数量,第二个为该组单词的性质编号,第三个由双引号包含,为该组单词的全部单词并由逗号分割。
4、一组单词的性质编号:0 为完全随机(基本不可能连接)、1 为肯定能够连接、其余数字为可能能够连接,此编号供自行调试代码使用。

测试数据生成器:

评分规则:

1、能够获得正确结果,得 2 分
2、能够在20秒内获得,得 1 分
下述代码作为名义20秒进行对比:
  1. Function Nominal20Sec#()
  2.     Dim t#, i&, j&, k#
  3.     t = Timer
  4.     For i = 1 To 5800
  5.         For j = 1 To 10000
  6.             Randomize: k = Rnd * Rnd
  7.         Next
  8.     Next
  9.     Nominal20Sec = Timer - t
  10.     Debug.Print Nominal20Sec
  11. End Function
复制代码
提示:

我在题目开贴后会另在VBA区专门开贴答疑,敬请关注。

是否参与评论:

可以

参考答案:

另加~



本帖子中包含更多资源

您需要 登录 才可以下载或查看,没有账号?免费注册

x

点评

函数声明中的 Variable 是否应为“Variant”  发表于 2014-2-14 14:43

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2014-1-16 11:08 | 显示全部楼层
放上一个半成品先
该半成品 忽略单词与单词间形成了小循环 且 该循环的所有首尾字符不存在于其他任意单词的首尾部分
这在楼主帖子中是个小概率事件 但是我不清楚是否应该考虑
比如 AB BA D 这样的形式 AB BA 形成循环 且 "A","B"不存在于其他单词的首尾
但是1W-6W的单词量 26个字母几乎全部涵盖
如果要考虑这种情况 这个半成品就是错误答案了
  1. Public Function CheckLinkability() ' As Variable
  2.     Dim t#: t = Timer
  3.     On Error GoTo END_FUNC
  4.     Dim aRes(1 To 3)
  5.     Dim nstr As String
  6.     Dim n As Integer
  7.     Dim s As String
  8.     Open ThisWorkbook.Path & "\单词接龙_测试数据.csv" For Input Access Read As #1
  9.     Line Input #1, nstr
  10.     n = CInt(nstr)
  11.     For i = 1 To n
  12.         Line Input #1, s
  13.         s = Replace(s, Chr(34), "")
  14.         arr = Split(s, ",")
  15.         Dim brr(): ReDim brr(0 To UBound(arr) - 2)
  16.         Dim bt() As Byte
  17.         For j = 0 To UBound(brr)
  18.             bt = StrConv(arr(j + 2), vbUnicode)
  19.             brr(j) = bt
  20.         Next
  21.         aRes(3) = aRes(3) & enabledo(brr)
  22.     Next
  23. END_FUNC:
  24.     Close #1
  25.     aRes(1) = "doryan" ' <- 你的论坛ID
  26.     aRes(2) = Timer - t
  27.     If Err Then Err.Clear: aRes(2) = -1: On Error GoTo 0
  28.     ' aRes(3) 为100个字母 T 或 F 的字符串,T 为能够接龙,F 为不能
  29.     Debug.Print aRes(2) & "," & aRes(3)
  30.     CheckLinkability = aRes
  31. End Function
  32. Private Function enabledo(arr) As String
  33. Dim huizong(97 To 122)
  34.     For i = 0 To UBound(arr)
  35.        huizong(arr(i)(0)) = huizong(arr(i)(0)) + 1
  36.        pos = arr(i)(UBound(arr(i)) - 3)
  37.        huizong(pos) = huizong(pos) - 1
  38.     Next
  39.     For i = 97 To 122
  40.         If huizong(i) <> 0 Then ct = ct + 1
  41.     Next
  42.     If ct = 2 Then   '一个唯一入口 一个唯一出口
  43.         enabledo = "T"
  44.     ElseIf ct = 0 Then   '回环形式 所有单词绕成一个圈 可以从任意单词进入
  45.         enabledo = "T"
  46.     Else
  47.         enabledo = "F"
  48.     End If
  49. End Function
复制代码

点评

a,b 两个字母就出错了,不能处理非连通图  发表于 2014-2-28 14:06

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2014-1-19 18:28 | 显示全部楼层
本帖最后由 yangyangzhifeng 于 2014-1-30 09:36 编辑

凑个热闹看看
  1. Public Function CheckLinkability() As Variant    Dim t#: t = Timer
  2.     On Error GoTo END_FUNC
  3.     Dim aRes(1 To 3)
  4.     Open ThisWorkbook.Path & "\单词接龙_测试数据.csv" For Input Access Read As #1
  5.     Call chk(aRes(3))
  6. END_FUNC:
  7.     Close #1
  8.     aRes(1) = "yangyangzhifeng" ' <- 你的论坛ID
  9.     aRes(2) = Timer - t
  10.     If Err Then Err.Clear: aRes(2) = -1: On Error GoTo 0
  11.     ' aRes(3) 为100个字母 T 或 F 的字符串,T 为能够接龙,F 为不能
  12.     CheckLinkability = aRes
  13. End Function
  14. Sub chk(tt)
  15. '算法如下:
  16. '对于首尾字母不相同的单词,以某一字母开始与结尾的单词数量差的总和要不大于2
  17. '若包含首尾字母相同的单词,且包含首尾字母不相同的单词,则此相同字母须在首尾字母不相同的单词中能找到以其开始或结尾的单词
  18. '若全部是首尾字母相同的单词,则开始字母只能是同一个
  19.     Dim ar() As Byte, sj, Start_Letters(97 To 122), End_Letters(97 To 122), Same_letter(97 To 122)
  20.     Dim n&, jg() As String, i&, j&, Start_End_Differ&, Sum_Differ&, st$, temp
  21.     sj = Split(StrConv(InputB(LOF(1), 1), vbUnicode), vbCrLf)
  22.     Reset
  23.     n = Val(sj(0))
  24.     ReDim jg(1 To n)
  25.     For i = 1 To UBound(jg)
  26.         st = Split(sj(i), Chr(34))(1)
  27.         temp = Split(st, ",")
  28.         For j = 0 To UBound(temp)
  29.             ar = temp(j)
  30.             n = UBound(ar)
  31.             If ar(0) = ar(n - 1) Then
  32.                 Same_letter(ar(0)) = 1
  33.             Else
  34.                 Start_Letters(ar(0)) = Start_Letters(ar(0)) + 1
  35.                 End_Letters(ar(n - 1)) = End_Letters(ar(n - 1)) + 1
  36.             End If
  37.         Next
  38.         If Application.Sum(Start_Letters, End_Letters) = 0 Then
  39.             If Application.Sum(Same_letter) = 1 Then jg(i) = "T" Else jg(i) = "F"
  40.         Else
  41.             For j = 97 To 122
  42.                 If Start_Letters(j) <> End_Letters(j) Then
  43.                     Start_End_Differ = Start_End_Differ + 1
  44.                     If Start_End_Differ > 2 Then Exit For
  45.                     Sum_Differ = Sum_Differ + Abs(Start_Letters(j) - End_Letters(j))
  46.                     If Sum_Differ > 2 Then Exit For
  47.                 End If
  48.                 If Same_letter(j) > 0 Then
  49.                     If Start_Letters(j) + End_Letters(j) = 0 Then Exit For
  50.                 End If
  51.             Next
  52.             If j = 123 Then jg(i) = "T" Else jg(i) = "F"
  53.         End If
  54.         Erase Start_Letters: Erase End_Letters: Erase Same_letter
  55.         Sum_Differ = 0: Start_End_Differ = 0
  56.     Next
  57.     tt = Join(jg, "")
  58. End Sub
复制代码

点评

不能处理非连通图,这一组单词出错:a,ab,cd,dc  发表于 2014-2-28 14:37

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2014-1-20 18:37 | 显示全部楼层
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件       ★免费下载 ★       ★ 使用帮助
本帖最后由 yjh_27 于 2014-1-22 15:05 编辑

  1. Public Function CheckLinkability()
  2.     Dim t#: t = Timer
  3.     On Error GoTo END_FUNC
  4.     Dim aRes(1 To 3)
  5.     Open ThisWorkbook.Path & "\单词接龙_测试数据.csv" For Input Access Read As #1
  6.     Dim ss(97 To 122, 1 To 3) As Long
  7.     Line Input #1, TextLine1
  8.     For i = 1 To TextLine1
  9.         Line Input #1, TextLine
  10.         fl = Split(TextLine, ",")
  11.         Erase ss
  12.         js1 = 0
  13.         js2 = 0
  14.         k = UBound(fl)
  15.         fl(2) = Mid(fl(2), 2)
  16.         fl(k) = Left(fl(k), Len(fl(k)) - 1)
  17.         For j = 2 To k
  18.             s1 = Asc(Left(fl(j), 1))
  19.             s2 = Asc(Right(fl(j), 1))
  20.             If s1 = s2 Then
  21.                 ss(s1, 3) = ss(s1, 3) + 1
  22.             Else
  23.                 ss(s1, 1) = ss(s1, 1) + 1
  24.                 ss(s2, 2) = ss(s2, 2) + 1
  25.             End If
  26.         Next
  27.         
  28.         For ii = 97 To 122
  29.             If ss(ii, 1) > ss(ii, 2) Then
  30.                 js1 = js1 + ss(ii, 1) - ss(ii, 2)
  31.             ElseIf ss(ii, 1) < ss(ii, 2) Then
  32.                 js2 = js2 + ss(ii, 2) - ss(ii, 1)
  33.             End If
  34.             If ss(ii, 3) > 0 Then
  35.                 If ss(ii, 1) + ss(ii, 2) = 0 Then js1 = 2
  36.             End If
  37.             If js1 > 1 Or js2 > 1 Then
  38.                 aRes(3) = aRes(3) & "F"
  39.                 Exit For
  40.             End If
  41.         Next
  42.         If ii > 122 Then aRes(3) = aRes(3) & "T"
  43.     Next
  44.    
  45.     ' ......
  46. END_FUNC:
  47.     Close #1
  48.     aRes(1) = "yjh_27" ' <- 你的论坛ID
  49.     aRes(2) = Timer - t
  50.     If Err Then Err.Clear: aRes(2) = -1: On Error GoTo 0
  51.     ' aRes(3) 为100个字母 T 或 F 的字符串,T 为能够接龙,F 为不能
  52.     CheckLinkability = aRes
  53. End Function
复制代码

点评

不能处理非连通图,这一组单词出错:a,ab,cd,dc  发表于 2014-2-28 14:38

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2014-1-31 12:40 | 显示全部楼层
  1. Public Function CheckLinkability() As Variable
  2.     Dim t#: t = Timer
  3.     Dim Num_Groups%, StrArr() As String, i%, arr, answer() As String, brr() As String
  4.     On Error GoTo END_FUNC
  5.     Dim aRes(1 To 3)
  6.     Open ThisWorkbook.Path & "\单词接龙_测试数据.csv" For Input Access Read As #1
  7.     ' ......
  8.     Input #1, Num_Groups
  9.     ReDim StrArr(1 To Num_Groups, 3)
  10.     ReDim answer(1 To Num_Groups)
  11.     i = 1
  12.     Do While Not EOF(1)
  13.     Input #1, StrArr(i, 1)
  14.     Input #1, StrArr(i, 2)
  15.     Input #1, StrArr(i, 3)
  16.     i = i + 1
  17.     Loop
  18.     For i = 1 To Num_Groups
  19.     ReDim brr(StrArr(i, 1) - 1)
  20.     arr = Split(StrArr(i, 3), ",")
  21.     brr = arr
  22.     answer(i) = GetAnswer(brr)
  23.     Next
  24.     aRes(3) = Join(answer, "")
  25. END_FUNC:
  26.     Close #1
  27.     aRes(1) = "eyeshot" ' <- 你的论坛ID
  28.     aRes(2) = Timer - t
  29.     If Err Then Err.Clear: aRes(2) = -1: On Error GoTo 0
  30.     ' aRes(3) 为100个字母 T 或 F 的字符串,T 为能够接龙,F 为不能
  31.     CheckLinkability = aRes
  32. End Function

  33. Private Function GetAnswer(MyArr() As String) As String
  34.     Dim x As Long, MyBrr() As String, d1, d2, Flag%
  35.     x = UBound(MyArr)
  36.     ReDim MyBrr(1 To x + 1, 2)
  37.         '初始化
  38.     Set d1 = CreateObject("scripting.dictionary")
  39.     Set d2 = CreateObject("scripting.dictionary")
  40.     Flag = 0
  41.     For i = 1 To 26
  42.         d1(Chr(96 + i)) = 0
  43.         d1(Chr(96 + i)) = 0
  44.     Next
  45.    
  46.     For i = 1 To x + 1
  47.         If Len(MyArr(i - 1)) = 1 Then
  48.         MyBrr(i, 1) = MyArr(i - 1): MyBrr(i, 2) = MyArr(i - 1)
  49.         Else
  50.         MyBrr(i, 1) = Left(MyArr(i - 1), 1): MyBrr(i, 2) = Right(MyArr(i - 1), 1)
  51.         End If
  52.         '统计各字母重复次数
  53.         d1(MyBrr(i, 1)) = d1(MyBrr(i, 1)) + 1
  54.         d2(MyBrr(i, 2)) = d2(MyBrr(i, 2)) + 1
  55.     Next
  56.     '判断首尾字母个数能否满足接龙,单个字母 |首-尾|>1则直接不能完成接龙,|首-尾|=1超过2个亦不能完成接龙
  57.     For i = 1 To 26
  58.         Select Case Abs(d1(Chr(96 + i)) - d2(Chr(96 + i)))
  59.         Case Is > 1
  60.         Flag = 10: Exit For
  61.         Case 1
  62.         Flag = Flag + 1
  63.         If Flag > 2 Then Exit For
  64.         End Select
  65.     Next
  66.     If Flag > 2 Then
  67.     GetAnswer = "F"
  68.     Else
  69.     GetAnswer = "T"
  70.     End If
  71.     d1.RemoveAll: d2.RemoveAll: Set d1 = Nothing: Set d2 = Nothing
  72. End Function
复制代码

点评

Variable都没改过来程序怎么调通的?不能处理 a,b  发表于 2014-2-28 14:19

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2014-2-14 18:15 | 显示全部楼层
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用  · 内置多项VBA编程加强工具       ★ 免费下载 ★      ★使用手册
楼主的题目没看懂意思,不过就算看懂,这两天也没时间来做了,双节嘛。
说下我的思路。
定义一个长度为26的数组PP(),对应A-Z
读入一个单词,若单词长度为1,跳过,否则读左边第一个字母的ASCII值,换算成1-26,假定第一个字母为N,则数组PP(14)=PP(14)+1;读最右边一个字母的ASCII值 ,换算成1-26,假定最右边一个字母为B,则PP(2)=PP(2)-1
读入完所有单词数据后,检测数组PP,若数组中每个项的值均为0,则读入的单词有多种排列方法。
若读入完所有单词数据后,只有两个项满足一个值为1,一个值为-1,其它的值为0时,假定PP(14)=1,PP(2)=-1,若它项为0,则所有单词数据有且仅有一种排列方式,并且接龙的第一个单词必定为N开头,接龙最后一个单词必定以B结尾。
若数组PP()中不满足上述条件,则所有单词无法构成接龙。
若要构成接龙,需根据数据PP中项的正负值,剔除不符合要求的单词。 假定P(1)=2,P(17)=-2,共它均为0,则可以查找以a开头,以t结尾, 如at,after,accpet 等的单词后再可以接龙。接龙的首单词也必定以a开头,最后一个单词也必定以t结尾。

单词接龙的方法,与经典问题七孔桥差不多。

点评

单字母单词有可能成为孤立点,直接跳过行吗?  发表于 2014-2-28 15:06

TA的精华主题

TA的得分主题

发表于 2014-2-14 20:05 | 显示全部楼层
本帖最后由 jsxjd 于 2014-2-16 14:06 编辑

有向连通图欧拉路径问题:用Split稳定在 6.5 Secs 左右,用StrConv稳定在 4.5 Secs左右

  1. Public Function CheckLinkability() As Variant
  2.     Dim t#: t = Timer
  3.     On Error GoTo END_FUNC
  4.     Dim aRes(1 To 3)
  5.     Open ThisWorkbook.Path & "\单词接龙_测试数据.csv" For Input Access Read As #1
  6.     ' ......
  7.     Dim I&, n&, T1&, T2&, s$
  8.     Input #1, n
  9.     For I = 1 To n
  10.         Input #1, T1, T2, s
  11.         aRes(3) = aRes(3) & WordSolitaire(s)
  12.     Next
  13.     ' ......
  14. END_FUNC:
  15.     Close #1
  16.     aRes(1) = "jsxjd" ' <- 你的论坛ID
  17.     aRes(2) = Timer - t
  18.     If Err Then Err.Clear: aRes(2) = -1: On Error GoTo 0
  19.     ' aRes(3) 为100个字母 T 或 F 的字符串,T 为能够接龙,F 为不能
  20.     CheckLinkability = aRes
  21. End Function
  22. Private Function WordSolitaire$(WordStr$)
  23.     Dim s, I&, J&, FinalVertex&, StartVertex&, nIn&, nOut&, nVertex&
  24.     Dim newVertex As Boolean, k, Dict
  25.     Dim Edges&(97 To 122, 97 To 122), Vertex&(97 To 122)
  26.     For Each s In Split(WordStr, ",")
  27.         I = Asc(s)
  28.         J = Asc(Right(s, 1))
  29.         Vertex(I) = 1: Vertex(J) = 1
  30.         Edges(I, J) = Edges(I, J) + 1
  31.     Next
  32.     WordSolitaire = "F"
  33.     For I = 97 To 122
  34.         nIn = 0: nOut = 0
  35.         For J = 97 To 122
  36.             nIn = nIn + Edges(J, I)
  37.             nOut = nOut + Edges(I, J)
  38.         Next
  39.         Select Case nOut - nIn
  40.             Case -1
  41.                 If FinalVertex > 0 Then Exit Function
  42.                 FinalVertex = I
  43.             Case 1
  44.                 If StartVertex > 0 Then Exit Function
  45.                 StartVertex = I
  46.             Case 0
  47.             Case Else
  48.                 Exit Function
  49.         End Select
  50.     Next
  51.     For I = 97 To 122
  52.         If Vertex(I) > 0 Then
  53.             nVertex = nVertex + 1
  54.             If StartVertex = 0 Then StartVertex = I
  55.         End If
  56.     Next
  57.    
  58.     Set Dict = CreateObject("Scripting.Dictionary")
  59.     Dict(StartVertex) = 0
  60.     Do
  61.         newVertex = False
  62.         For Each k In Dict.keys
  63.             J = CLng(k)
  64.             If Dict(J) = 0 Then
  65.                 For I = 97 To 122
  66.                     If J <> I Then
  67.                         If Edges(J, I) > 0 Then
  68.                             If Not Dict.Exists(I) Then Dict(I) = 0: newVertex = True
  69.                         End If
  70.                     End If
  71.                 Next
  72.                 Dict(J) = 1
  73.             End If
  74.         Next
  75.     Loop Until newVertex = False
  76.     If Dict.Count = nVertex Then WordSolitaire = "T"
  77.     Set Dict = Nothing
  78. End Function

复制代码


以下不使用split,速度有所提高:稳定在 4.5 Secs 左右
  1. Public Function CheckLinkability() As Variant
  2.     Dim t#: t = Timer
  3.     On Error GoTo END_FUNC
  4.     Dim aRes(1 To 3)
  5.     Open ThisWorkbook.Path & "\单词接龙_测试数据.csv" For Input Access Read As #1
  6.     ' ......
  7.     Dim I&, N&, T1&, T2&, s$
  8.     Input #1, N
  9.     For I = 1 To N
  10.         Input #1, T1, T2, s
  11.         aRes(3) = aRes(3) & WordSolitaire(s)
  12.     Next
  13.     ' ......
  14. END_FUNC:
  15.     Close #1
  16.     aRes(1) = "jsxjd" ' <- 你的论坛ID
  17.     aRes(2) = Timer - t
  18.     If Err Then Err.Clear: aRes(2) = -1: On Error GoTo 0
  19.     ' aRes(3) 为100个字母 T 或 F 的字符串,T 为能够接龙,F 为不能
  20.     CheckLinkability = aRes
  21. End Function
  22. Private Function WordSolitaire$(WordStr$)
  23.     Dim N&, I&, J&, FinalVertex&, StartVertex&, nIn&, nOut&, nVertex&
  24.     Dim b() As Byte, newVertex As Boolean, k, Dict
  25.     Dim Edges&(97 To 122, 97 To 122), Vertex&(97 To 122)
  26.    
  27.     b = StrConv(WordStr, vbFromUnicode)
  28.     I = b(LBound(b))
  29.     For N = LBound(b) + 1 To UBound(b)
  30.         If b(N) = 44 Then
  31.             J = b(N - 1)
  32.             Vertex(I) = 1: Vertex(J) = 1
  33.             Edges(I, J) = Edges(I, J) + 1
  34.             I = b(N + 1)
  35.         End If
  36.     Next
  37.     J = b(UBound(b))
  38.     Vertex(I) = 1: Vertex(J) = 1
  39.     Edges(I, J) = Edges(I, J) + 1
  40.    
  41.     WordSolitaire = "F"
  42.     For I = 97 To 122
  43.         nIn = 0: nOut = 0
  44.         For J = 97 To 122
  45.             nIn = nIn + Edges(J, I)
  46.             nOut = nOut + Edges(I, J)
  47.         Next
  48.         Select Case nOut - nIn
  49.             Case -1
  50.                 If FinalVertex > 0 Then Exit Function
  51.                 FinalVertex = I
  52.             Case 1
  53.                 If StartVertex > 0 Then Exit Function
  54.                 StartVertex = I
  55.             Case 0
  56.             Case Else
  57.                 Exit Function
  58.         End Select
  59.     Next
  60.     For I = 97 To 122
  61.         If Vertex(I) > 0 Then
  62.             nVertex = nVertex + 1
  63.             If StartVertex = 0 Then StartVertex = I
  64.         End If
  65.     Next
  66.     Set Dict = CreateObject("Scripting.Dictionary")
  67.     Dict(StartVertex) = 0
  68.     Do
  69.         newVertex = False
  70.         For Each k In Dict.keys
  71.             J = CLng(k)
  72.             If Dict(J) = 0 Then
  73.                 For I = 97 To 122
  74.                     If J <> I And Edges(J, I) > 0 Then
  75.                         If Not Dict.Exists(I) Then
  76.                             Dict(I) = 0: newVertex = True
  77.                             If Dict.Count = nVertex Then Exit Do
  78.                         End If
  79.                     End If
  80.                 Next
  81.                 Dict(J) = 1
  82.             End If
  83.         Next
  84.     Loop Until newVertex = False
  85.     If Dict.Count = nVertex Then WordSolitaire = "T"
  86.     Set Dict = Nothing
  87. End Function
复制代码

评分

1

查看全部评分

TA的精华主题

TA的得分主题

发表于 2014-2-16 10:49 | 显示全部楼层
本帖最后由 wcymiss 于 2014-2-17 08:29 编辑

  1. Public Function CheckLinkability()
  2.     Dim t#: t = Timer
  3.     On Error GoTo END_FUNC
  4.     Dim aRes(1 To 3)
  5.     Open ThisWorkbook.Path & "\单词接龙_测试数据.csv" For Input Access Read As #1
  6.     aRes(3) = MyMain(InputB(LOF(1), 1))
  7. END_FUNC:
  8.     Close #1
  9.     aRes(1) = "wcymiss" ' <- 你的论坛ID
  10.     aRes(2) = Timer - t
  11.     If Err Then Err.Clear: aRes(2) = -1: On Error GoTo 0
  12.     ' aRes(3) 为100个字母 T 或 F 的字符串,T 为能够接龙,F 为不能
  13.     CheckLinkability = aRes
  14. End Function

  15. Private Function MyMain(ByRef bytCsv() As Byte) As String
  16.     Dim i As Long
  17.     Dim lngStart As Long, lngEnd As Long
  18.     Dim k As Boolean, s As String
  19.     k = False
  20.     For i = 0 To UBound(bytCsv)
  21.         If bytCsv(i) = 34 Then
  22.             If k Then
  23.                 lngEnd = i - 1: k = False
  24.                 If MyCheck(bytCsv, lngStart, lngEnd) Then s = s & "T" Else s = s & "F"
  25.             Else
  26.                 lngStart = i + 1: k = True
  27.             End If
  28.         End If
  29.     Next
  30.     MyMain = s
  31. End Function

  32. Private Function MyCheck(ByRef bytCsv() As Byte, _
  33.     ByRef lngStart As Long, ByRef lngEnd As Long) As Boolean
  34.     Dim i As Long
  35.     Dim aWord(97 To 122, 97 To 122) As Integer
  36.     Dim aLetter(97 To 122) As Long
  37.     Dim shou As Byte, wei As Byte
  38.     shou = bytCsv(lngStart)
  39.     For i = lngStart To lngEnd
  40.         If bytCsv(i) = 44 Then
  41.             wei = bytCsv(i - 1)
  42.             aWord(shou, wei) = 1
  43.             aLetter(shou) = aLetter(shou) + 1
  44.             aLetter(wei) = aLetter(wei) - 1
  45.             shou = bytCsv(i + 1)
  46.         End If
  47.     Next
  48.     wei = bytCsv(lngEnd)
  49.     aWord(shou, wei) = 1
  50.     aLetter(shou) = aLetter(shou) + 1
  51.     aLetter(wei) = aLetter(wei) - 1
  52.     If Not CheckLetter(aLetter) Then MyCheck = False: Exit Function
  53.     If Not CheckWord(aWord, shou, wei) Then MyCheck = False: Exit Function
  54.     MyCheck = True
  55. End Function

  56. Private Function CheckLetter(ByRef aLetter) As Boolean
  57.     Dim i As Integer
  58.     Dim n_1 As Integer, n_2 As Integer
  59.     CheckLetter = True
  60.     For i = LBound(aLetter) To UBound(aLetter)
  61.         If aLetter(i) <> 0 Then
  62.             If aLetter(i) = 1 Then
  63.                 n_1 = n_1 + 1
  64.                 If n_1 > 1 Then CheckLetter = False: Exit Function
  65.             ElseIf aLetter(i) <> -1 Then
  66.                 CheckLetter = False: Exit Function
  67.             End If
  68.         End If
  69.     Next
  70. End Function

  71. Private Function CheckWord(ByRef aWord, ByRef shou As Byte, ByRef wei As Byte) As Boolean
  72.     Dim x As Byte, y As Byte, z As Byte
  73.     Dim k As Boolean
  74.     Dim aRow() As Boolean, aCol() As Boolean
  75.     ReDim aRow(LBound(aWord) To UBound(aWord))
  76.     ReDim aCol(LBound(aWord, 2) To UBound(aWord, 2))
  77.     aWord(shou, wei) = 2
  78.     For z = LBound(aWord) To UBound(aWord)
  79.         If aWord(z, shou) = 1 Then aWord(z, shou) = 2
  80.     Next
  81.     aCol(shou) = True
  82.     For z = LBound(aWord, 2) To UBound(aWord, 2)
  83.         If aWord(wei, z) = 1 Then aWord(wei, z) = 2
  84.     Next
  85.     aRow(wei) = True
  86.     Do
  87.         k = False
  88.         For x = LBound(aWord) To UBound(aWord)
  89.             For y = LBound(aWord, 2) To UBound(aWord, 2)
  90.                 If aWord(x, y) = 2 Then
  91.                     If Not aRow(y) Then
  92.                         For z = LBound(aWord, 2) To UBound(aWord, 2)
  93.                             If aWord(y, z) = 1 Then
  94.                                 aWord(y, z) = 2
  95.                                 If Not k Then k = True
  96.                             End If
  97.                         Next
  98.                         aRow(y) = True
  99.                     End If
  100.                     If Not aCol(x) Then
  101.                         For z = LBound(aWord) To UBound(aWord)
  102.                             If aWord(z, x) = 1 Then
  103.                                 aWord(z, x) = 2
  104.                                 If Not k Then k = True
  105.                             End If
  106.                         Next
  107.                         aCol(x) = True
  108.                     End If
  109.                 End If
  110.             Next
  111.         Next
  112.     Loop While k
  113.     For x = LBound(aWord) To UBound(aWord)
  114.         For y = LBound(aWord, 2) To UBound(aWord, 2)
  115.             If aWord(x, y) = 1 Then CheckWord = False: Exit Function
  116.         Next
  117.     Next
  118.     CheckWord = True
  119. End Function
复制代码

评分

2

查看全部评分

TA的精华主题

TA的得分主题

发表于 2014-2-19 09:03 | 显示全部楼层
竞赛时间到,请已交卷的同学误再修改答案,以免影响评分,谢谢。
先开贴,待楼主总结评分。

TA的精华主题

TA的得分主题

发表于 2014-2-28 15:29 | 显示全部楼层
2至5楼都没有很好地处理“连通性”
  2楼、5楼不能处理“a,b”这两个单词
  3楼、4楼不能处理“a,ab,cd,dc” 这组单词

8楼通过使用 InputB 函数提升了数据读入效率
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

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

GMT+8, 2024-11-21 19:09 , Processed in 0.051033 second(s), 11 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

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

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

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