程序代碼如下：
Private Sub Degr(p() As Integer, ByVal n As Integer)
Dim i As Integer, j As Integer
Do While n > 0
OutL p
If p(1) = n Then '如果第壹位是n
i = 0
Do '從左端開始找出最長的連續遞降序列
i = i + 1
If i = n Then Exit Sub
Loop Until p(i) <> p(i + 1) + 1
j = i
Do '找出遞降序列末尾數字的下壹個數字
i = i + 1
Loop Until p(i) = p(j) - 1
Swap p(i), p(i - 1) '將它與序列末尾數字交換
For i = 1 To n - j '將遞減序列倒轉後放置在排列右端
p(i) = p(i + j)
Next
For i = 1 To j
p(n - i + 1) = n - i + 1
Next
Else '如果最高位不是n
i = 0 '從左端開始
Do '找出n所在位置
i = i + 1
Loop Until p(i) = n
Swap p(i), p(i - 1)'將n與其左邊數字交換
End If
Loop
End Sub