並べ替えの最小手順について

質問

パンケーキソートに似ているのかもしれませんが、以下の問の最小手順について教えていただければと思います。

(問)
いま、1から10までの整数がめちゃくちゃに並んでいる。
例:(9,5,7,3,10,2,1,4,6,8)
これを(1,2,3,4,5,6,7,8,9,10)と並べ替えたい。
行える操作は、「ある数1つのみを現在の場所から引き抜いて、別の場所に挿入する。」とする。このときの最小手順を知りたい。

例えば、(1,2,9,3,4,5,6,7,8,10)の場合は、最小手順としては、「9を現在の3番目から引き抜いて、9番目に挿入する」の1手順です。

私自身の最終的な目標としてExcelでこれをやりたいので(いまA列に縦に数字が並んでいて、途中経過がB列、C列・・と示されていく感じで。もちろん自動並べ替えは使わずに)、VBA等で示して頂けるとかなり助かりますが、考え方だけ教えていただけるのでも有難いです。

どうぞ宜しくお願い致します。

回答No.2

tmppassenger · ベストアンサー

この場合、最終的に「動かさなかった」数字に着目すると、動かさなかった数字たちは、最初から小さい順に並んでいたことになります。そして、動かしたそれぞれの数字に関しては、それぞれ一回ずつ動かすと所望の位置に動かせます（挿入できます）。
★ 動かさなかった数字の間に、一つずつ順に挿入していけばいいですね

というわけで、問題はなるべくたくさんの数字を動かさなくてすむ方法、つまり「最初から小さい順に並んでいる部分集合の中で最大の長さのもの」を探し出す、ということになります。それが見つかれば、あとは動さなかくてはいけない数字は、順に所望の位置に挿入すればいい。

で、これは結局「最長増加部分列」(longest increasing sequence : LLS)を見つけ出すことに相当します。これについては、
https://en.wikipedia.org/wiki/Longest_increasing_subsequence
の demoのgifアニメがわかりやすいので、参照してください。

(9,5,7,3,10,2,1,4,6,8) の場合は、 (1, 4, 6, 8)が最長増加部分列になるので、後は残りの数字を順に挿入していけばよい。

お礼

ありがとうございます。勉強になります。
つまり最長増加部分列を見つけるアルゴリズムが肝ですね。
お示しいただいたリンク先など参考にさせていただきます。

回答No.10

Mathmi

＞n=35で試してみると、オーバーフローのエラー
＞nやNumをLong型に変えたのですが、そうすると今度はメモリー不足のエラー
こちらで試してみた所、n_ary=50の時オーバーフローにならず、60の時オーバーフローになりました。
（サンプルの配列の問題？）

計上済みの項目を、開始時から外せば、もう少し軽くなりそうです。
（こちらの環境では、オーバーフローが60から70になりました。int型をlong型にした場合、n=100まで、時間はかかりましたが求められました。

変更点は
共通変数に「Dim blnX() As Boolean 'その項目が増加部分列として計上済みかどうか」
mainルーチンの最初辺りに「ReDim blnX(1 To n_Ary)」追加
増加部分列を検索のループ部分に「If blnX(i) = True Then GoTo CONTINUE」、nextの前に「CONTINUE:」追加
GetISサブルーチンのReDim Preserve S(n).i(1 To n_Index)の直前2個所に「blnX(i) = True」追加
です。

最長でない増加部分列を、毎回配列Sから削除していけば、時間はかかりますが、更に少ないメモリでいけるかもしれません。

お礼

ありがとうございます。参考にさせていただきます。
質問をしてから、下記リンクを参考に私の方でもコードを作ってみました。
一応うまくいってそうです。
https://www.vitoshacademy.com/vba-longest-increasing-subsequence/
http://www.ii.uni.wroc.pl/~lorys/IPL/article76-1-1.pdf

---------

Option Explicit
Public Const NO_PREVIOUS = -1
Sub Main()
Dim arr_seq As Variant
Dim arr_len As Variant
Dim arr_pre As Variant
Dim LISlen As Long
Dim lng_best As Long
arr_seq = Array(1, 2, -5.5, -6, -5, -3, 23, 123, 3, 2, -23, -5, 54, 100, 200, 300, 1111, 23412, 3, 4, 6, 5, 7, 8, 9, 19, 65, 64, 2)
ReDim arr_len(UBound(arr_seq))
ReDim arr_pre(UBound(arr_seq))
lng_best = CalculateLongestIncreasingSubsequence(arr_seq, arr_len, arr_pre)
LISlen = Application.WorksheetFunction.Max(arr_len)
Call PrintLIS_All(arr_seq, arr_pre, arr_len, LISlen, lng_best)
End Sub
Public Function CalculateLongestIncreasingSubsequence(ByRef arr_seq As Variant, ByRef arr_len As Variant, ByRef arr_pre As Variant) As Long
Dim lng_best_len As Long: lng_best_len = 0
Dim lng_best_ind As Long: lng_best_ind = 0
Dim x As Long
Dim i As Long
For x = LBound(arr_seq) To (UBound(arr_seq)) Step 1
arr_len(x) = 1
arr_pre(x) = NO_PREVIOUS
For i = 0 To x Step 1
If (arr_seq(i) < arr_seq(x)) And (arr_len(i) + 1 > arr_len(x)) Then
arr_len(x) = arr_len(i) + 1
arr_pre(x) = i
If arr_len(x) > lng_best_len Then
lng_best_len = arr_len(x)
lng_best_ind = x
End If
End If
Next i
Next x
CalculateLongestIncreasingSubsequence = lng_best_ind
End Function
Public Function Left1(zIndex As Long, ByRef arr_len As Variant)
Dim tmpIndex As Long
Dim zarr_len As Long
Dim zarr_pre As Long
Dim answer As Long
zarr_len = arr_len(zIndex)
answer = NO_PREVIOUS
On Error GoTo Skipleft1
For tmpIndex = zIndex - 1 To LBound(arr_len) Step -1
If arr_len(tmpIndex) = zarr_len Then
answer = tmpIndex
Exit For
End If
Next tmpIndex
Skipleft1:
Left1 = answer
End Function
Public Function Left2(zIndex As Long, ByRef arr_len As Variant, ByRef arr_pre As Variant)
Dim tmpIndex As Long
Dim zarr_len As Long
Dim zarr_pre As Long
Dim answer As Long
zarr_len = arr_len(zIndex)
zarr_pre = arr_pre(zIndex)
answer = NO_PREVIOUS
On Error GoTo Skipleft2
For tmpIndex = zIndex - 1 To zarr_pre Step -1
If arr_len(tmpIndex) = zarr_len - 1 Then
answer = tmpIndex
Exit For
End If
Next tmpIndex
Skipleft2:
Left2 = answer
End Function
Public Sub PrintLIS_All(ByRef arr_seq As Variant, ByRef arr_pre As Variant, ByRef arr_len As Variant, LISlen As Long, lng_best As Long)
Dim LIS As Variant
Dim LISind As Variant
Dim tmpLIS As Variant
Dim lastIndex As Long
Dim z As Long
Dim z_1 As Long
Dim z_2 As Long
Dim counter As Long
Dim LISwidth As Long
Dim i, j, m1, m2 As Long
For lastIndex = UBound(arr_seq) To lng_best Step -1
ReDim LIS(LISlen - 1, 0)
ReDim LISind(LISlen - 1, 0)
If arr_len(lastIndex) = LISlen Then
LIS(LISlen - 1, 0) = arr_seq(lastIndex)
LISind(LISlen - 1, 0) = lastIndex
z = lastIndex
For j = 0 To LISlen - 2
counter = 0
LISwidth = UBound(LIS, 2)
For i = 0 To LISwidth
z = LISind(LISlen - 1 - j, i)
z_1 = Left2(z, arr_len, arr_pre)
If z_1 <> -1 And arr_seq(z_1) < LIS(LISlen - 1 - j, i) Then
Do
If counter <> 0 Then
ReDim Preserve LIS(LISlen - 1, LISwidth + counter)
ReDim Preserve LISind(LISlen - 1, LISwidth + counter)
For z_2 = LISlen - 1 To arr_len(z_1) Step -1
LIS(z_2, LISwidth + counter) = LIS(z_2, i)
LISind(z_2, LISwidth + counter) = LISind(z_2, i)
Next z_2
LIS(arr_len(z_1) - 1, LISwidth + counter) = arr_seq(z_1)
LISind(arr_len(z_1) - 1, LISwidth + counter) = z_1
z_1 = Left1(z_1, arr_len)
Else
LIS(arr_len(z_1) - 1, i) = arr_seq(z_1)
LISind(arr_len(z_1) - 1, i) = z_1
z_1 = Left1(z_1, arr_len)
End If
counter = counter + 1
If z_1 = -1 Then Exit Do
Loop While arr_seq(z_1) < LIS(LISlen - 1 - j, i)
End If
LISwidth = UBound(LIS, 2)
counter = 0
Next i
Next j
End If
ReDim tmpLIS(UBound(LIS, 1))
For m2 = LBound(LIS, 2) To UBound(LIS, 2)
For m1 = LBound(LIS, 1) To UBound(LIS, 1)
tmpLIS(m1) = LIS(m1, m2)
Next m1
Debug.Print Join(tmpLIS, " ")
Next m2
Next lastIndex
End Sub

回答No.9

Mathmi

全ての増加部分列を検索するルーチンを作ってみました。
長さ1も含みますし、力業ですが、n=35の時でも短時間で求められました。

アルゴリズムとしては「あるiに対して、i<jかつX(i)<X(j)であるj1、j2……を検索」を、1<i<n-1まで再起させただけです。

Option Explicit

Dim X() As Integer '対象配列
Dim n_Ary As Integer '対象配列の項目数
Dim S() As SubSequence '増加部分列
Dim MaxL As Integer '最長増加部分列の長さ
Dim LIS() As SubSequence '最長増加部分列

Type SubSequence
i() As Integer 'index/item。配列Xのインデックスを格納。
End Type

Sub Main()
Dim i As Integer, j As Integer, n As Integer
Dim Num As Integer

'対象配列を格納
n_Ary = 35
ReDim X(1 To n_Ary)
For i = 1 To n_Ary
X(i) = Cells(i, 3).Value
Next i

'増加部分列を検索
ReDim S(0)
For i = 1 To n_Ary - 1
Num = UBound(S) + 1
ReDim Preserve S(Num)
ReDim Preserve S(Num).i(1 To 1)
S(Num).i(1) = i
Call GetIS(Num, i)
Next i

'最長増加部分列を配列に書き出し
For i = 1 To UBound(S)
If MaxL < UBound(S(i).i) Then
MaxL = UBound(S(i).i)
End If
Next i

ReDim LIS(0)
For i = 1 To UBound(S)
If MaxL = UBound(S(i).i) Then
n = UBound(LIS) + 1
ReDim Preserve LIS(n)
ReDim Preserve LIS(n).i(1 To MaxL)
For j = 1 To MaxL
LIS(n).i(j) = X(S(i).i(j))
Cells(j, n + 7).Value = LIS(n).i(j)
Next j
End If
Next i
End Sub

Sub GetIS(ByVal Num As Integer, ByVal Begin As Integer)
'増加部分列S(Num)の最後の値X(Begin)に対し、Begin<jかつX(Begin)<X(j)となる全てのj1、j2……を求めるルーチン
Dim i As Integer, n As Integer
Dim n_Index As Integer '検索したjを追加するインデックス番号
Dim myFlg As Boolean 'それまでにjが検索されたか。falseならまだ、trueなら検出済み。

n_Index = UBound(S(Num).i) + 1

'再起サブルーチンを呼び出し
For i = Begin + 1 To n_Ary
If X(Begin) < X(i) Then
If myFlg = False Then
myFlg = True
ReDim Preserve S(Num).i(1 To n_Index)
S(Num).i(n_Index) = i
Call GetIS(Num, i)
Else
n = UBound(S) + 1
ReDim Preserve S(n)
S(n) = S(Num)
ReDim Preserve S(n).i(1 To n_Index)
S(n).i(n_Index) = i
Call GetIS(n, i)
End If
End If
Next i
End Sub

お礼

ありがとうございます！
まだ中身をきちんと見れていないですが、試しにn=35で試してみると、オーバーフローのエラーが出てしまいました。
エラー箇所はSub GetISの”再起サブルーチンを呼び出し”の”n = UBound(S) + 1”の箇所です。nがInteger型なので、32767から32768になろうとするところでエラーが出ていたようです。
そこで、nやNumをLong型に変えたのですが、そうすると今度はメモリー不足のエラー。
私のＰＣでは厳しそうです。

回答No.8

HohoPapa

>私のPCでは要素数は20過ぎくらいが限界で、
>多分Long型で扱える数の限界か、PCリソースの限界か
リソースによるかもしれませんが、
処理時間を気にしないのであれば、
31個まではイケルと思います。

>本当は300くらいの要素数で実行したいのです
総当たりでは手に負えませんね。

過日ポストしたコードにはバグもありましたし、
効率の悪いところがあるので、
一応、再ポストしておきます。
なお、処理時間が長いので
どこまで進んかわかるようにログも吐き出すようにしました。

Option Explicit

Sub test11()

　Const CMax = 10 '最大配列数
　Dim P(CMax) As Integer　'評価数値配列
　Dim M(CMax) As Integer　'抽出した配列
　Dim CCnt As Long　　　　'カウンター
　Dim TGsh As Worksheet　 'ワークシート
　Dim OldNum As Long
　Dim HitCnt As Long
　Dim MCnt As Long　　　　'総当たりカウンター
　Dim RCnt As Long　　　　'行カウンター
　Dim HitFlg As Boolean
　Dim MaxHitCnt As Long

　'ログファイル準備
　Dim strFilePath As String
　strFilePath = ActiveWorkbook.Path & "\test1.txt" 'ファイルパス
　Open strFilePath For Output As #1
　Close #1

　'変数をクリアー
　Erase P
　MaxHitCnt = 0
　RCnt = 20

　'作業シートを定義
　Set TGsh = ThisWorkbook.Sheets(1)

　'配列変数Pにソート前の値群をセット
　For CCnt = 1 To CMax
　　P(CCnt) = TGsh.Cells(7, CCnt + 10).Value
　Next CCnt

　'最長増加部分列の文字数を求める
　For MCnt = 1 To (2 ^ CMax - 1)

　　'ログに出力
　　If MCnt Mod 100000 = 0 Then
　　　Open strFilePath For Append As #1
　　　Print #1, Format(Now, "HH:MM:SS") & Chr(9) & MCnt & "/" & ExDeciToBin(MCnt, CMax)
　　　Close #1
　　End If

　　HitCnt = 0
　　OldNum = 0
　　HitFlg = True
　　For CCnt = 1 To CMax
　　　If Mid(ExDeciToBin(MCnt, CMax), CCnt, 1) = 1 Then
　　　　If P(CCnt) > OldNum Then
　　　　　OldNum = P(CCnt)
　　　　　HitCnt = HitCnt + 1
　　　　Else
　　　　　HitCnt = 0
　　　　　Exit For
　　　　End If
　　　End If
　　Next CCnt
　　If MaxHitCnt < HitCnt Then
　　　MaxHitCnt = HitCnt
　　End If
　Next MCnt

　'ログに出力
　Open strFilePath For Append As #1
　Print #1, Format(Now, "HH:MM:SS") & Chr(9) & "MaxHitCnt:" & MaxHitCnt
　Close #1

　'最長増加部分列を全数抽出
　For MCnt = 1 To (2 ^ CMax - 1)

　　'ログに出力
　　If MCnt Mod 100000 = 0 Then
　　　Open strFilePath For Append As #1
　　　Print #1, Format(Now, "HH:MM:SS") & Chr(9) & MCnt & "/" & ExDeciToBin(MCnt, CMax)
　　　Close #1
　　End If

　　Erase M
　　HitCnt = 0
　　OldNum = 0
　　HitFlg = True
　　For CCnt = 1 To CMax
　　　If Mid(ExDeciToBin(MCnt, CMax), CCnt, 1) = 1 Then
　　　　If P(CCnt) > OldNum Then
　　　　　OldNum = P(CCnt)
　　　　　HitCnt = HitCnt + 1
　　　　　M(CCnt) = P(CCnt)
　　　　Else
　　　　　HitFlg = False
　　　　　Exit For
　　　　End If
　　　End If
　　Next CCnt

　　'抽出結果をシートに出力
　　If ((HitCnt >= MaxHitCnt) And (HitFlg = True)) Then
　　　RCnt = RCnt + 1
　　　For CCnt = 1 To CMax
　　　　TGsh.Cells(RCnt, CCnt + 10).Value = M(CCnt)　'11列目から出力
　　　Next CCnt
　　　TGsh.Cells(RCnt, 5).Value = "'" & ExDeciToBin(MCnt, CMax)
　　　TGsh.Cells(RCnt, 9).Value = HitCnt
　　End If
　Next MCnt

End Sub

Sub abc()
　Debug.Print ExDeciToBin(2 ^ 31 - 1, 33)
End Sub

'Excel VBAで10進数を2進数に変換し、固定長で出力
Public Function ExDeciToBin(deci As Long, pLen As Integer) As String
　Dim ln As Long
　Dim stemp As String
　Dim i As Long
　Dim count As Long

　stemp = "1"
　'deciより小さい、最大の２のべき乗の値を探す
　count = Ex2noBeki(deci)
　ln = deci - 2 ^ count
　　 '筆算と同じように繰り返す
　For i = count - 1 To 0 Step -1
　　If ln < 2 ^ i Then
　　　stemp = stemp & "0"
　　Else
　　　stemp = stemp & "1"
　　　ln = ln - (2 ^ i)
　　End If
　Next i
　If Len(stemp) < pLen Then　'ゼロパディング
　　ExDeciToBin = String((pLen - Len(stemp)), "0") & stemp
　Else
　　ExDeciToBin = stemp
　End If
End Function

'最大の２のべき乗の値を探す
Private Function Ex2noBeki(deci As Long) As Integer
　Dim i As Integer

　i = 0
　Do
　　'deciより大きい
　　If deci < 2 ^ i Then
　　　'その一つ前のべき乗
　　　Ex2noBeki = i - 1
　　　Exit Function
　　End If
　　i = i + 1
　Loop
End Function

お礼

ありがとうございます！
お示しいただいたコードについていくつか考察しました。
1) LISの文字数を求めるところは、総当たりではないVBAコードが下記リンクにあります。
https://www.vitoshacademy.com/vba-longest-increasing-subsequence/
2) LISを全数抽出するところは、例えば要素数が10、LIS長が4であれば、0000001111～1111000000までの総当たりでいいですね。
3) 上記の2)は、10C4(10!/6!4!)の組み合わせだけ考えればもっと早そうです。

いずれにしても要素数が300とかでは歯が立ちませんでした。(nCrの数があんなに大きくなるとは・・)

ネットで探すと、LISを全数抽出するアルゴリズムの論文が2000年に出ていました。
http://www.ii.uni.wroc.pl/~lorys/IPL/article76-1-1.pdf

この2.1 Reporting all subsequencesのアルゴリズムをVBAコードにしたい、したいんだけれども私の力量未だ及ばず(涙

回答No.7

HohoPapa

ちょっと修正して再ポストします。

要素の数が10程度でよければ
組み合わせの数は2^10=1024と限定的なので
総当たりでもいいんじゃないかと思います。

課題に興味を惹かれ、興味本位で書いてみました。
よかったら参考にしてください。

Option Explicit

Sub test11()

　Const CMax = 10 '最大配列数
　Dim P(CMax) As Integer　'評価数値配列
　Dim M(CMax) As Integer　'抽出した配列
　Dim CCnt As Long　　　　'カウンター
　Dim TGsh As Worksheet　 'ワークシート
　Dim OldNum As Long
　Dim HitCnt As Long
　Dim MCnt As Long　　　　'総当たりカウンター
　Dim RCnt As Long　　　　'行カウンター
　Dim HitFlg As Boolean
　Dim MaxHitCnt As Long

　'変数をクリアー
　Erase P
　MaxHitCnt = 0
　RCnt = 20

　'作業シートを定義
　Set TGsh = ThisWorkbook.Sheets(1)

　'配列変数Pにソート前の値群をセット
　For CCnt = 1 To CMax
　　P(CCnt) = TGsh.Cells(7, CCnt + 10).Value
　Next CCnt

　'最長増加部分列の文字数を求める
　For MCnt = 1 To (2 ^ CMax - 1)
　　HitCnt = 0
　　OldNum = 0
　　HitFlg = True
　　For CCnt = 1 To CMax
　　　If Mid(ExDeciToBin(MCnt, CMax), CCnt, 1) = 1 Then
　　　　If P(CCnt) > OldNum Then
　　　　　OldNum = P(CCnt)
　　　　　HitCnt = HitCnt + 1
　　　　End If
　　　End If
　　Next CCnt
　　If MaxHitCnt < HitCnt Then
　　　MaxHitCnt = HitCnt
　　End If
　Next MCnt

　'最長増加部分列を全数抽出
　For MCnt = 1 To (2 ^ CMax - 1)
　　Erase M
　　HitCnt = 0
　　OldNum = 0
　　HitFlg = True
　　For CCnt = 1 To CMax
　　　If Mid(ExDeciToBin(MCnt, CMax), CCnt, 1) = 1 Then
　　　　If P(CCnt) > OldNum Then
　　　　　OldNum = P(CCnt)
　　　　　HitCnt = HitCnt + 1
　　　　　M(CCnt) = P(CCnt)
　　　　Else
　　　　　HitFlg = False
　　　　End If
　　　End If
　　Next CCnt

　　'抽出結果をシートに出力
　　If ((HitCnt >= MaxHitCnt) And (HitFlg = True)) Then
　　　RCnt = RCnt + 1
　　　For CCnt = 1 To 10
　　　　TGsh.Cells(RCnt, CCnt + 10).Value = M(CCnt)　'11列目から出力
　　　Next CCnt
　　　TGsh.Cells(RCnt, 5).Value = "'" & ExDeciToBin(MCnt, CMax)
　　　TGsh.Cells(RCnt, 9).Value = HitCnt
　　End If
　Next MCnt

End Sub

'Excel VBAで10進数を2進数に変換し、固定長で出力
Public Function ExDeciToBin(deci As Long, pLen As Integer) As String
　Dim ln As Long
　Dim stemp As String
　Dim i As Integer
　Dim count As Integer

　stemp = "1"
　'deciより小さい、最大の２のべき乗の値を探す
　count = Ex2noBeki(deci)
　ln = deci - 2 ^ count
　　 '筆算と同じように繰り返す
　For i = count - 1 To 0 Step -1
　　If ln < 2 ^ i Then
　　　stemp = stemp & "0"
　　Else
　　　stemp = stemp & "1"
　　　ln = ln - (2 ^ i)
　　End If
　Next i
　If Len(stemp) < pLen Then　'ゼロパディング
　　ExDeciToBin = String((pLen - Len(stemp)), "0") & stemp
　Else
　　ExDeciToBin = stemp
　End If
End Function

'最大の２のべき乗の値を探す
Private Function Ex2noBeki(deci As Long) As Integer
　Dim i As Integer

　i = 0
　Do
　　'deciより大きい
　　If deci < 2 ^ i Then
　　　'その一つ前のべき乗
　　　Ex2noBeki = i - 1
　　　Exit Function
　　End If
　　i = i + 1
　Loop
End Function

お礼

ありがとうございました！
お示しいただいたコードの繰り返し処理を改変したりして、ちょっと高速化したりして遊ばせていただきました。
結論として、私のPCでは要素数は20過ぎくらいが限界で、多分Long型で扱える数の限界か、PCリソースの限界か、と相成りました。
本当は300くらいの要素数で実行したいのですが、なんにせよ大変参考になりました。

回答No.6

HohoPapa

要素の数が10程度でよければ
組み合わせの数は2^10=1024と限定的なので
総当たりでもいいんじゃないかと思います。

課題に興味を惹かれ、興味本位で書いてみました。
よかったら参考にしてください。

Option Explicit

Sub test11()

　Const CMax = 10 '最大配列数
　Dim P(CMax) As Integer　'評価数値配列
　Dim M(CMax) As Integer　'抽出した配列
　Dim CCnt As Long　　　　'カウンター
　Dim TGsh As Worksheet　 'ワークシート
　Dim OldNum As Long
　Dim HitCnt As Long
　Dim MCnt As Long　　　　'総当たりカウンター
　Dim RCnt As Long　　　　'行カウンター
　Dim HitFlg As Boolean
　Dim MaxHitCnt As Long

　'変数をクリアー
　Erase P
　MaxHitCnt = 0
　RCnt = 20

　'作業シートを定義
　Set TGsh = ThisWorkbook.Sheets(1)

　'配列変数Pにソート前の値群をセット
　For CCnt = 1 To CMax
　　P(CCnt) = TGsh.Cells(7, CCnt + 10).Value
　Next CCnt

　'最長増加部分列の文字数を求める
　For MCnt = 1 To (2 ^ CMax - 1)
　　HitCnt = 0
　　OldNum = 0
　　HitFlg = True
　　For CCnt = 1 To CMax
　　　If Mid(ExDeciToBin(MCnt, CMax), CCnt, 1) = 1 Then
　　　　If P(CCnt) > OldNum Then
　　　　　OldNum = P(CCnt)
　　　　　HitCnt = HitCnt + 1
　　　　End If
　　　End If
　　Next CCnt
　　If MaxHitCnt < HitCnt Then
　　　MaxHitCnt = HitCnt
　　End If
　Next MCnt

　'最長増加部分列を全数抽出
　For MCnt = 1 To (2 ^ CMax - 1)
　　Erase M
　　HitCnt = 0
　　OldNum = 0
　　HitFlg = True
　　For CCnt = 1 To CMax
　　　If Mid(ExDeciToBin(MCnt, CMax), CCnt, 1) = 1 Then
　　　　If P(CCnt) > OldNum Then
　　　　　OldNum = P(CCnt)
　　　　　HitCnt = HitCnt + 1
　　　　　M(CCnt) = P(CCnt)
　　　　Else
　　　　　HitFlg = False
　　　　End If
　　　End If
　　Next CCnt

　　'抽出結果をシートに出力
　　If ((HitCnt >= MaxHitCnt) And (HitFlg = True)) Then
　　　RCnt = RCnt + 1
　　　For CCnt = 1 To 10
　　　　TGsh.Cells(RCnt, CCnt + 10).Value = M(CCnt)　'11列目から出力
　　　Next CCnt
　　　TGsh.Cells(RCnt, 5).Value = "'" & ExDeciToBin(MCnt, 10)
　　　TGsh.Cells(RCnt, 9).Value = HitCnt
　　End If
　Next MCnt

End Sub

'Excel VBAで10進数を2進数に変換し、固定長で出力
Public Function ExDeciToBin(deci As Long, pLen As Integer) As String
　Dim ln As Long
　Dim stemp As String
　Dim i As Integer
　Dim count As Integer

　stemp = "1"
　'deciより小さい、最大の２のべき乗の値を探す
　count = Ex2noBeki(deci)
　ln = deci - 2 ^ count
　　 '筆算と同じように繰り返す
　For i = count - 1 To 0 Step -1
　　If ln < 2 ^ i Then
　　　stemp = stemp & "0"
　　Else
　　　stemp = stemp & "1"
　　　ln = ln - (2 ^ i)
　　End If
　Next i
　If Len(stemp) < pLen Then　'ゼロパディング
　　ExDeciToBin = String((10 - Len(stemp)), "0") & stemp
　Else
　　ExDeciToBin = stemp
　End If
End Function

'最大の２のべき乗の値を探す
Private Function Ex2noBeki(deci As Long) As Integer
　Dim i As Integer

　i = 0
　Do
　　'deciより大きい
　　If deci < 2 ^ i Then
　　　'その一つ前のべき乗
　　　Ex2noBeki = i - 1
　　　Exit Function
　　End If
　　i = i + 1
　Loop
End Function

回答No.5

tmppassenger

> #4さん

それだと、例えば (2, 3, 4, 5, 1)だと本来は1を2の前に動かせば終了だけど、5, 4, 3, 2,を順に動かさなければいけなくなります。
この場合、2, 3, 4, 5は動かさなくて良く（最長増加部分列）、残る1を動かせばよい、となります。

お礼

そうですね。やはり何をさておいてもまずは最長増加部分列ですね。

回答No.4

Mathmi

思いつきだけでまだ検証してないのですが。

・配列の各数字の位置が、ソート位置からどれだけずれているかを取得する。
・本来の位置よりも左側にある数字は、即ち移動しなければならない数字である。
・移動しなければならない数字の内最も大きな数字を引き抜き、その本来の位置に挿入する。
（引き抜いた数字から挿入する位置までは、だるま落としのようにずれていく）

を繰り返せばどうでしょうか？
移動する必要のある数字だけを移動できるような気がします。

お礼

ありがとうございます。
私もそう考えたりもしましたが、No.5の方が反例を示されています。

回答No.3

Mathmi

No.1の方がおっしゃるように、ソート結果が分かっていればバケツソートの変種で行ける……と思ったのですが、「引き抜いて挿入する」とのことですので、No2の方がおっしゃってるやり方の方が手数が少なくて済みそうですね。

一応バケツソート方式のVBAを組んでみました。
ソート元の配列を取得するセルは、任意で変更してください。

Option Explicit

Sub AryGet()
Dim i As Integer
Dim BaseAry() As Integer 'ソート前配列
Dim GoalAry() As Integer 'ソート後配列
ReDim BaseAry(1 To 10)
ReDim GoalAry(LBound(BaseAry) To UBound(BaseAry))

Rows("1:10").Clear '<-以前の出力結果をクリア。
For i = LBound(BaseAry) To UBound(BaseAry)
BaseAry(i) = Cells(i + 11, 2).Value '<-ソート元の配列を取得。
GoalAry(i) = i
Next i

Call AryWrite(0, BaseAry, GoalAry, 0, 0)
End Sub

Sub AryWrite(ByRef cnt As Integer, ByRef BaseAry() As Integer, ByRef GoalAry() As Integer, ByRef BefI As Integer, ByRef AftI As Integer)
'cnt手目の配列を出力。入れ替えた項目を着色。
'ソート済みかチェックして、完了していれば終了する。
Dim i As Integer
Dim Flg As Boolean

'セルに出力。
For i = LBound(BaseAry) To UBound(BaseAry)
Cells(i, cnt + 1).Value = BaseAry(i)
If i = BefI Or i = AftI Then
Cells(i, cnt + 1).Interior.Color = RGB(192, 192, 192)
End If
Next i

'ソート済みか確認。
Flg = True
For i = LBound(BaseAry) To UBound(BaseAry)
If BaseAry(i) <> GoalAry(i) Then
Flg = False
Exit For
End If
Next i
If Flg = True Then
MsgBox cnt & "回でソート完了。"
Exit Sub
End If

'ソートサブルーチンを呼び出し
Call ArySort(cnt, BaseAry, GoalAry)
End Sub

Sub ArySort(ByRef cnt As Integer, ByRef BaseAry() As Integer, ByRef GoalAry() As Integer)
Dim i As Integer, j As Integer, buf As Integer
Dim BefI As Integer, AftI As Integer 'BeforeItem/AfterItem。入れ替える配列番号。

For i = LBound(BaseAry) To UBound(BaseAry)
If BaseAry(i) <> GoalAry(i) Then
BefI = i '入れ替え前の配列番号を取得。
For j = BefI + 1 To UBound(BaseAry)
If BaseAry(j) = GoalAry(BefI) Then
AftI = j '入れ替え語の配列番号を取得。
buf = BaseAry(BefI)
BaseAry(BefI) = BaseAry(AftI)
BaseAry(AftI) = buf
Call AryWrite(cnt + 1, BaseAry, GoalAry, BefI, AftI)
End If
Next j
End If
Next i
End Sub

お礼

ありがとうございました。大変お手数おかけしました。
実際にお示しいただいたコードを試してみました。相当早く処理が終わりますね。
で、おそらくなんですが、これは「ある２つの要素の順番をスワップする」場合のコードになっていませんでしょうか？
実際、ソート元が(9,5,7,3,10,2,1,4,6,8)の場合でコードを試すと最少手順が9回と出てきますが、No.2の方がおっしゃっているように、最長増加部分列（(3,4,6,8) or (2,4,6,8) or (1,4,6,8)）の長さは4なので、10 - 4 = 6回の手順で完了しなければならない、と思います。

ネットでコードを探していると、最長増加部分列（LIS）を探すVBAコードがありました。
https://www.vitoshacademy.com/vba-longest-increasing-subsequence/

現時点ではこれを使ってみようかなと思っています。ただ、上のリンクのコードだと、LISが複数ある場合（上記の例の場合は3つある）もその中の１つしか出力されないので、改変したいと思っています。（LISの数だけシートを追加して、それぞれに結果を出力したいなと）
追加で申し訳ございませんが、そこの部分のヒントなどもあれば頂けますと本当にありがたいです。

回答No.1

ToOrisugaru

上記条件で最初から要素が１０個あり、１~１０までの数字しか存在しないのであれば、要素の値ー１をしたものを添え字として、配列に格納していくのが一番手順が少ないのではないでしょうか？

お礼

ありがとうございます。
いろいろすっ飛ばすとそうなりそうですね