Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
楼主: grf1973

[VBA] 用VBA解欧拉计划题目(83)--路径和:四个方向

[复制链接]
发表于 2017-12-14 15:42 | 显示全部楼层
Do
  mn = 10 ^ 8
  For Each ky In d.keys
    If mn > ky Then mn = ky
  Next
  crr = Split(Mid(d(mn), 2), ",")
  For i = 0 To UBound(crr) Step 2
    r = crr(i)
    c = crr(i + 1)
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

发表于 2017-12-14 15:43 | 显示全部楼层
第3段:
    If r > 1 Then If brr(r - 1, c) = False Then arr(r - 1, c) = arr(r - 1, c) + arr(r, c): d(arr(r - 1, c)) = d(arr(r - 1, c)) & "," & r - 1 & "," & c: brr(r - 1, c) = True
    If r < r1 Then If brr(r + 1, c) = False Then arr(r + 1, c) = arr(r + 1, c) + arr(r, c): d(arr(r + 1, c)) = d(arr(r + 1, c)) & "," & r + 1 & "," & c: brr(r + 1, c) = True
    If c > 1 Then If brr(r, c - 1) = False Then arr(r, c - 1) = arr(r, c - 1) + arr(r, c): d(arr(r, c - 1)) = d(arr(r, c - 1)) & "," & r & "," & c - 1: brr(r, c - 1) = True
    If c < c1 Then If brr(r, c + 1) = False Then arr(r, c + 1) = arr(r, c + 1) + arr(r, c): d(arr(r, c + 1)) = d(arr(r, c + 1)) & "," & r & "," & c + 1: brr(r, c + 1) = True
  Next i
  d.Remove mn
Loop Until brr(r1, c1) = True
回复

使用道具 举报

发表于 2017-12-14 15:45 | 显示全部楼层
第4段居然发不上来,其实就是输出右下角格子内容。
回复

使用道具 举报

发表于 2017-12-14 15:47 | 显示全部楼层
输出arr(r1, c1) 内容结束
回复

使用道具 举报

发表于 2017-12-14 15:53 | 显示全部楼层
原来msgbox发不出?
回复

使用道具 举报

发表于 2017-12-14 16:08 | 显示全部楼层
其实我82题的解决方法也是逐步推算,每次都得到确切结果,不需要反复重算,极端情况时也不会发生判断错误,83题也一样。
但是,应该可以在我的基础进一步改进,毕竟我只能想出比较高效的方法,但是没有写出更高效实现的代码。
回复

使用道具 举报

 楼主| 发表于 2017-12-15 10:56 | 显示全部楼层
大灰狼1976 发表于 2017-12-14 16:08
其实我82题的解决方法也是逐步推算,每次都得到确切结果,不需要反复重算,极端情况时也不会发生判断错误, ...

嗯,用你的代码测试过了。结果正确。神奇。
回复

使用道具 举报

 楼主| 发表于 2017-12-15 10:58 | 显示全部楼层
大灰狼1976 发表于 2017-12-14 16:08
其实我82题的解决方法也是逐步推算,每次都得到确切结果,不需要反复重算,极端情况时也不会发生判断错误, ...

这网站怎么回事,不能发图片,不能发代码。搞毛啊。
回复

使用道具 举报

发表于 2017-12-15 21:15 | 显示全部楼层
Sub test2()
    Dim ar, br&(), cr, dr, dic, i&, j&, k&, m&, n&, r&, s&, t&, tms#
    tms = Timer
   
    ar = Sheets(1).[a1].CurrentRegion '读取节点之间的路程数据表
    m = UBound(ar): n = UBound(ar, 2) '最大行m、最大列n
   
    ReDim br&(1 To m, 1 To n) '数组b记录累计路程
    br(1, 1) = ar(1, 1) '起始位置
   
    Set dic = CreateObject("Scripting.Dictionary") '字典记录当前路程值 对应的节点位置
    dic(ar(1, 1)) = " " & 1 & " " & 1 '起始位置
   
    Do
        kr = dic.keys '提取当前所有路程值
        s = kr(0)
        For k = 1 To UBound(kr)
            If kr(k) < s Then s = kr(k) '检查当前最小路程值
        Next
        
        cr = Split(dic(s)) '还原最短路程对应的节点位置
        For k = 1 To UBound(cr) Step 2 '依次检查
            i = cr(k): j = cr(k + 1) '还原行、列位置
            If i > 1 Then t = ar(i - 1, j) + br(i, j): If br(i - 1, j) = 0 Then br(i - 1, j) = t: dic(t) = dic(t) & " " & i - 1 & " " & j
            If i < m Then t = ar(i + 1, j) + br(i, j): If br(i + 1, j) = 0 Then br(i + 1, j) = t: dic(t) = dic(t) & " " & i + 1 & " " & j
            If j > 1 Then t = ar(i, j - 1) + br(i, j): If br(i, j - 1) = 0 Then br(i, j - 1) = t: dic(t) = dic(t) & " " & i & " " & j - 1
            If j < n Then t = ar(i, j + 1) + br(i, j): If br(i, j + 1) = 0 Then br(i, j + 1) = t: dic(t) = dic(t) & " " & i & " " & j + 1
            '依次检查上、下、左、右 是否为空或有更小路程
        Next
        dic.Remove s '字典中去掉这个当前最小路程值
    Loop Until br(m, n) '检查直到终点
   
    Debug.Print Format(Timer - tms, "0.000s"); br(m, n)
   
    Sheet2.Activate
    [a1].CurrentRegion.Interior.ColorIndex = 0
    [a1].CurrentRegion = ""
    [a1].Resize(m, n) = br
   
    ReDim cr(1 To m, 1 To n)
    i = m: j = n
    cr(i, j) = br(i, j)
    Cells(i, j).Interior.ColorIndex = 7
    s = ar(i, j)
    Do
        ReDim dr(3)
        If i > 1 Then dr(0) = br(i - 1, j): t = dr(0): r = 0
        If i < m Then dr(1) = br(i + 1, j): t = dr(1): r = 1
        If j > 1 Then dr(2) = br(i, j - 1): t = dr(2): r = 2
        If j < n Then dr(3) = br(i, j + 1): t = dr(3): r = 3
        
        For k = 0 To 3
            If dr(k) Then If dr(k) < t Then t = dr(k): r = k
        Next
        If r = 0 Then
            i = i - 1
        ElseIf r = 1 Then
            i = i + 1
        ElseIf r = 2 Then
            j = j - 1
        ElseIf r = 3 Then
            j = j + 1
        End If
        
        cr(i, j) = ar(i, j)
        Cells(i, j).Interior.ColorIndex = 7
        s = s + ar(i, j)
    Loop Until i + j = 2
   
    Debug.Print s
   
    Sheet3.Activate
    [a1].Resize(m + 1, n + 1) = ""
    [a1].Resize(m, n) = cr
    MsgBox Format(Timer - tms, "0.000s") & vbCr & s
End Sub
回复

使用道具 举报

 楼主| 发表于 2017-12-15 22:08 | 显示全部楼层
Good Job!
回复

使用道具 举报

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

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 04:28 , Processed in 0.298876 second(s), 6 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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