用VBA模拟外星人入侵

Mengkelyu

上次在群里聊到了一个题目：
一个外星人来到地球后，它每天都会在以下四件事情中等可能地选择一件来完成
（1）自我毁灭
（2）分裂成两个
（3）分裂成三个
（4）什么都不做

以后每天，每个外星人都会做一次选择，彼此之间相互独立，求最终没有外星人的概率。

于是，我决定用Excel来做这个的模拟。
首先我增加了这些假设：外星人的繁殖是在一个50*50的容器里。为了简单，我假定它会从下面三件事情中选一个做。
（1）自我毁灭
（2）分裂成两个
（3）分裂成三个
记录每天结束后容器里外星人的占有率，并绘图。

做好后大概是这个样子：

Mengkelyu

实现这个游戏比我想象中复杂一些。请看下面的代码：


Dim container As Range
Dim container_values As Variant
Dim activeworkers As Range
Dim cnt As Long


Sub Run_Simulation()

Set container = Range(Cells(15, 1), Cells(15 + 50, 50))
container_values = container.Value
'ini是初始外星人的位置，activeworkers 是所有现在活着的外星人'
Set activeworkers = Range("ini")
'记录外星人的数目'
cnt = 1
'记录天数'
For i = 1 To Range("td").Value
Range("Recorder") = "Day " & Str(i)
For Each cell2 In activeworkers
'执行分裂'
    Call dice(cell2)
Next
If activeworkers Is Nothing Then
MsgBox "Your invasion has failed"
 Exit Sub
End If
 Range("or") = "Occupying rate: " & Str(Round(activeworkers.Cells.Count / container.Cells.Count * 100, 2)) & "%"
Range("log").Offset(i - 1, 0) = Range("Recorder")
Range("log").Offset(i - 1, 1) = Round(activeworkers.Cells.Count / container.Cells.Count * 100, 2)
ActiveSheet.ChartObjects("Chart 3").Activate
ActiveChart.SetSourceData Source:=Range("log").Resize(i, 2)

DoEvents

 Next i


End Sub

Sub dice(thiscell)

Dim rn As Double, change As Double, iti As Long, volume As Long, change_1 As Long, change_2 As Long
volume = 50

rn = Rnd()

If rn > 0.66 Then
  '分裂两个'
   change_1 = Int((volume * volume - cnt) * rn + 1)
   change_2 = Int((volume * volume - cnt - 1) * rn + 1)
    For Each cell In container
    If cell.Interior.ThemeColor <> xlThemeColorAccent1 Then iti = iti + 1
    If iti = change_1 Or iti = change_2 Then
        cell.Interior.ThemeColor = xlThemeColorAccent1
        Set activeworkers = Union(activeworkers, cell)
        cnt = cnt + 1
    End If
    Next
    
ElseIf rn > 0.33 Then
 '分裂一个'
change = Int((volume * volume - cnt) * rn + 1)
    For Each cell In container
    If cell.Interior.ThemeColor <> xlThemeColorAccent1 Then iti = iti + 1
    If iti = change Then
        cell.Interior.ThemeColor = xlThemeColorAccent1
        Set activeworkers = Union(activeworkers, cell)
        cnt = cnt + 1
    End If
    Next

Else
 '死亡'
   thiscell.Interior.ThemeColor = xlThemeColorDark1
   Set activeworkers = getExcluded(activeworkers, thiscell)
   cnt = cnt - 1
End If
End Sub

Sub initiate()

Cells.Interior.ThemeColor = xlThemeColorDark1
Range("Ini").Interior.ThemeColor = xlThemeColorAccent1

ActiveSheet.ChartObjects("Chart 3").Activate
ActiveChart.SetSourceData Source:=Range("log").Resize(1, 2)

End Sub
Function getExcluded(ByVal rngMain As Range, rngExc) As Range

    Dim rngTemp     As Range
    Dim rng         As Range

    Set rngTemp = rngMain

    Set rngMain = Nothing

    For Each rng In rngTemp
        If rng.Address <> rngExc.Address Then
            If rngMain Is Nothing Then
                Set rngMain = rng
            Else
                Set rngMain = Union(rngMain, rng)
            End If
        End If
    Next

    Set getExcluded = rngMain



End Function

Mengkelyu

excel在这里
Replicator.zip