ExcelのVBAで高速に組換え処理ができる方法

質問

• ExcelのVBAを使用して、スケジュールの組み合わせを効率的に導き出すプログラムを作成する方法について説明します。
• 数値を一列に並べて、複数のコースが被らないように4行分組み替える方法を解説します。
• コース番号には制限がなく、7のコースGは配置の制約がありますが、その他のコースは隣接して配置されます。

回答No.5

nag0720 · ベストアンサー

すでに回答が出ていますが、別の方法を。

＃４のコードは条件に合う組み合わせをランダムに調べる方法ですが、
このコードは、条件に合う組み合わせを重複なく順々に表示します。

Sub 組み合わせ()
Dim i As Integer, j As Integer, k As Integer
Dim n As Long, m As Long, Cnt As Long
Dim S0(6) As Byte, SW(6) As Byte
Dim S(3599, 14) As Byte
Dim SS(120000, 1) As Integer
Dim IsOK As Boolean
Dim ii As Integer, jj As Integer
Dim nn As Long

For i = 0 To 6
S0(i) = i + 1
Next
n = 0
Do
If S0(6) <> 7 Then
k = 0
For i = 0 To 6
S(n, k) = S0(i)
k = k + 1
If S0(i) <= 4 Or S0(i) = 6 Then
S(n, k) = S0(i)
k = k + 1
End If
If S0(i) <= 3 Then
S(n, k) = S0(i)
k = k + 1
End If
Next
n = n + 1
End If

For i = 5 To 0 Step -1
If S0(i) < 7 And S0(i) < S0(i + 1) Then
For j = i To 6
SW(j) = S0(j)
Next
For j = i + 1 To 6
S0(j) = SW(7 + i - j)
If S0(j) > SW(i) Then
S0(i) = S0(j)
S0(j) = SW(i)
SW(i) = 99
End If
Next
Exit For
End If
Next
Loop While S0(0) < 7

ActiveSheet.Select
Cnt = 0
nn = 0
n = 0 ' MAX 115920 通り
For i = 0 To 3599
For j = i + 1 To 3599
IsOK = True
For k = 0 To 14
If S(i, k) = 7 Then
IsOK = (S(j, k) = 7)
Else
IsOK = (S(i, k) <> S(j, k))
End If
If Not IsOK Then Exit For
Next
If IsOK Then
SS(n, 0) = i
SS(n, 1) = j
If S(i, 0) > S(SS(nn, 0), 0) Then
nn = n
End If
n = n + 1

For m = 0 To nn - 1
ii = SS(m, 0)
jj = SS(m, 1)
IsOK = True
For k = 0 To 14
IsOK = (S(ii, k) <> S(i, k) And S(ii, k) <> S(j, k) And S(jj, k) <> S(i, k) And S(jj, k) <> S(j, k))
If Not IsOK Then Exit For
Next
If IsOK Then
For k = 0 To 14
Cells(Cnt * 5 + 1, k + 1) = S(ii, k)
Cells(Cnt * 5 + 2, k + 1) = S(jj, k)
Cells(Cnt * 5 + 3, k + 1) = S(i, k)
Cells(Cnt * 5 + 4, k + 1) = S(j, k)
Next
Cells(Cnt * 5 + 4, 1).Select
Cnt = Cnt + 1
If MsgBox("続行しますか？", 1) = vbCancel Then Exit Sub
End If
Next
End If
Next
Next
End Sub

お礼

ありがとうございます。

コードも書いて頂き非常に助かります。

気になったのですが、１行目の頭と３行目の頭が毎回１１１と２２２になっておりますが、
試行回数を増やしていくと最終的に他の数値に変わっていくのでしょうか。