用Excel+Vba,做了一个简单的命理类小工具

user999

大家好，我是一个编程的初学者。疫情期间，已经被隔离３０天了。怕人呆费了。一直在努力学习，充电。
今天，在这里分享一个小程序。
是用Excel+Vba实现的6个硬币算命。
－－－－－－
先说下，这个算命的流程：
就是虔诚的先想个由头，然后扔六次硬币，按照组合不同，有一套解卦的说辞。跟周易一样，出卦随机，解挂固定。以前吃这碗饭的，基础就是你得把解挂背下来，不能临时去翻书。
这个程序，就是把这个事情自动化。

这个是出卦以后的页面情况。暂时还没考虑美化ＵＩ这个事。文件附件有。有好奇的可以自己改。
一共两种出卦方式。一种是扔一次硬币，自己根据具体情形鼠标点一下对应按钮，
一种是自动出６次随机挂，用三角按钮。
重置功能是字面意思。
说下咋实现的：
一，对应解挂的那套说辞，提前在sheet1里面，用excel的数据→分列，分成了５列，然后分别显示出来，就是右边的那个样子。
然后右边的内容很简单，使用的就是ＶＬＯＯＫＵＰ。根据左侧Ａ３～Ｆ３这一行，对应的数字，如果是正面，数字是１，反面就是０.最终组合成的六位，去sheet1里找答案。
这里面我把Ａ３～Ｆ３使用excel的＆命令，放在一个单元格了。
左侧所有按钮，除了清除，其他按钮都做了防呆检测，就是当前有卦的时候，直接按正反和自动是无效的。必须先清除。后起新卦。
其实严格来说，这个事情，除了弹出来的提示窗以外，都可以直接就用ＥＸＣＥＬ的函数搞定。
对应起卦的ＶＢＡ程序如下：
自动起６卦：

[Visual Basic] 纯文本查看 复制代码

?

01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28

Sub auto()       Dim x As Integer               If Len(Sheet2.Range("f3")) <> 0 Then                       MsgBox ("先清除，后起新卦")             Exit Sub                   End If                   With Sheet2                       .Cells(4, 1).Value = Application.WorksheetFunction.RandBetween(0, 1)             .Cells(4, 2).Value = Application.WorksheetFunction.RandBetween(0, 1)             .Cells(4, 3).Value = Application.WorksheetFunction.RandBetween(0, 1)             .Cells(4, 4).Value = Application.WorksheetFunction.RandBetween(0, 1)             .Cells(4, 5).Value = Application.WorksheetFunction.RandBetween(0, 1)             .Cells(4, 6).Value = Application.WorksheetFunction.RandBetween(0, 1)             For x = 1 To 6                 If .Cells(4, x).Value = 1 Then                     .Cells(3, x) = "O"                     Else                         .Cells(3, x) = "X"                 End If             Next         End With End Sub

单独起卦：

[Visual Basic] 纯文本查看 复制代码

?

01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24

Sub &#213;y()   Dim i   With Sheet2 i = .Cells(3, Columns.Count).End(xlToLeft).Column + 1   If Len(.Range("f3")) <> 0 Then     MsgBox ("请清除以后，起新卦")         Exit Sub End If   If Len(.Range("a3")) = 0 And Len(.Range("f3")) = 0 Then     .Range("a3").Value = "O"         .Range("a4").Value = 1     Else         .Cells(3, i) = "O"             .Cells(4, i) = 1               End If   End With   End Sub

user999

wangyihao 发表于 2022-4-11 21:31
六爻卦，下载下来看看

～厉害直接说这是六爻卦。

我是看了一个人的文章以后，做的这个工具。
那个爻是正起，反查。

他文章里说的意思是：
比如起卦顺序是　　正正正正正反。
　　　　　　　　　１１１１１０
去找解卦的时候，实际看的是　　反正正正正正。
　　　　　　　　　　　　　　　０１１１１１

我这里也是按他这个规矩弄的。不知道是对是错。
因为当时文章下就有人说还有正起正查的。

所以，如果你需要修改顺序，在Ｃ１４单元格，
里面原函数是：　=F4&E4&D4&C4&B4&A4
把顺序　弄成　＝A4&B4&C4&D4&E4&F4
就是按照起卦顺序去找答案。
Ｃ１４单元格我玩了个小套路，其实是有字的，我把字体颜色弄成白色，就看不出来了。

wangyihao

user999 发表于 2022-4-12 10:17
～厉害直接说这是六爻卦。

我是看了一个人的文章以后，做的这个工具。

谢谢！我看了一下，是按你这个顺序排的，自右往左排的，这个方法几乎不用，准确率不知是怎样的，就当娱乐吧，只是我觉得，硬币反面为阳爻，画O，硬币正面为阴爻，画X，要不有些卦就对不上了；比如按先后顺序，3个反面，1个正面，1个反面，1个正面，我就用XOXOOO来表示，这与用3个硬币摇卦的方法就一致了，为水天需卦，我一般习惯用3个硬币摇的那种方法，有时会有变爻出来，能反映出发展的情况。这里也有参考的（http://www.360doc.com/content/15/1227/14/18142477_523447136.shtml），这里也就直接是从右往左排的，然后从左往右去查看的

qqpoly

这个对于术理有研究的，这个还是不错的

jipinfeche

楼主实乃自强不息之人

hf123qwe

这个还是不错的

cherrypi

娱乐一下很不错的，谢谢分享。

潇洒浪子

能打开使用了  谢谢楼主！！

zr2019

下载了，谢谢楼主分享

桥段

自动化干掉了算卦的人

wangyihao

六爻卦，下载下来看看