Josephus环

约瑟夫问题是个有名的问题：N个人围成一圈，从第一个开始报数，第M个将被杀掉，最后剩下一个，其余人都将被杀掉。例如N=6，M=5，被杀掉的人的序号为5，4，6，2，3。最后剩下1号。

方法一.a

Option Explicit
'用元素循环的方法解决Joseph环的问题
Sub Joseph_1()
'定义元素长度，关键值
Dim m&, n&
'定义元素数组,变量
Dim arrM(), iM&
'定义计数项,累计出圈数
Dim iCount&, jCount&
'输出过程数组,变量
Dim arrOut(), mOut&, nOut&
'====================================
With Sheet2
m = .Cells(2, 2)
n = .Cells(3, 2)
ReDim arrM(1 To m)
  For iM = 1 To m
    arrM(iM) = iM    '数组初始化为0
  Next
iCount = 0  '初始化计算项
jCount = 0
ReDim arrOut(1 To m, 1 To m)
'------------------循环-----------------------------
Do Until jCount = m - 1
  For iM = 1 To m
   If arrM(iM) <> 0 Then    '排除已经移除项
    iCount = iCount + 1
     If iCount = n Then     '计数=值
      arrM(iM) = 0
      iCount = 0
      jCount = jCount + 1
      '-----输出过程数组-----------------------
       For mOut = 1 To m
         arrOut(jCount, mOut) = arrM(mOut)
       Next
      '-----------------------------------------
     End If
    End If
  Next
Loop
'-------------------输出-------------------------
.[A12].CurrentRegion.Clear
.[A12].Resize(UBound(arrOut), m) = arrOut
End With
'====================================
End Sub

方法一.b

Option Explicit
'用collection建立单循环链表的方式解决Josephus环
Sub Joseph_2()
'定义集合,变量
Dim cM As Collection, iC&
'定义元素长度，关键值
Dim m&, n&
'定义collection指针,计数量,界限
Dim sp&, iCount&, Limit&
'输出过程数组,变量
Dim arrOut(), mOut&, nOut&
'=========================================
Set cM = New Collection
With Sheet3
m = .Cells(2, 2)
n = .Cells(3, 2)
'-----------------------------------------
For iC = 1 To m
  cM.Add iC  '数据读入集合
Next
ReDim arrOut(1 To m, 1 To m)
'----------------------------------------
iC = 0      '初始化collection变量
iCount = 0  '初始化计数项
sp = 0      '初始化指针
'Limit = cM.Count    '初始化界限
Do
    sp = sp + 1   '指针移+1
    If sp > cM.Count Then
     sp = 1
    End If
    iCount = iCount + 1   '计算项+1
    If iCount = n Then    '如果点数=关键值
     cM.Remove (sp)     '移除
     iCount = 0         '重新初始化计数项
     sp = sp - 1        '指针移回前一数据项
'-----输出过程数组------------------------
      mOut = mOut + 1
       For iC = 1 To cM.Count
         arrOut(mOut, iC) = cM.Item(iC)
       Next
   End If
'------------------------------------------
  If cM.Count = 1 Then Exit Do  '退出循环
Loop
'--------------输出---------------------------
.[A12].CurrentRegion.Clear
.[A12].Resize(UBound(arrOut), m) = arrOut
End With
'=========================================
End Sub

方法二

Option Explicit

'用数学归纳法 , 递归公式进行计算
'递归公式:g(n,k)=((g(n-1,k)+k-1) mod n)+1
'n为总人数,k为关键字段
'公式来源
'https://en.wikipedia.org/wiki/Josephus_problem
Sub Joseph_3()
Dim m&, n&, r&    '定义变量
With Sheet4
m = .Cells(2, 2)     '人数
n = .Cells(3, 2)     '报数
Sheet1.Cells(21, 4) = Josephus(m, n)    '输出结果

End With
End Sub

Function Josephus(n, k)
'n为人数;k为报数
If n = 1 Then
  Josephus = 1      '递归出口
Else
  Josephus = ((Josephus(n - 1, k) + k - 1) Mod n) + 1   '递归公式
End If
End Function