ExcelのVBAで高速に組換え処理がしたい

質問

スケジュールの組み合わせを何通りか導き出すプログラムを作成しているのですが、苦戦しております。
開発言語はExcelのVBAです。VBAの中で配列か変数を使って設計しようと考えております。

やりたいことは、数値＝コース番号としまして、複数あるコースを一列に並べて、1日に他のコースと被らないように並べ替えたいのです。

コースによって受講日数が変動しますので、例えばコースAは3日間なので111となります。コースF
だと66になります。
これらを連結したものを、上下で同じコースが被らないように４つ配置したいのです。
コース同士は隣接するようにします。間が空かないように配置します。

【 コース番号 】

１・・・コースA（3日間）　　５・・・コースE（1日間）
２・・・コースB（3日間）　　６・・・コースF（2日間）
３・・・コースC（3日間）　　７・・・コースG（1日間）
４・・・コースD（2日間）

【　条件　】

・コースは互いに隣接しているようにする（コース間が空くことがないようにする）
・7のコースGはコースとコースの間に挟まるように配置し、1行目と2行目が同じ日になるように配置します。また、3行目と4行目が同じ日になるようにします。
・コースの順序に制限はありません。

下記のように数値を一列に並べて、
1 1 1 2 2 2 3 3 3 4 4 5 6 6 7

更に上下で被らないように4行分並べます。
例外として7のコースBだけは端っこには配置させないようにして、尚且つ1行目2行目が同じ日に実施するようにし、3行目と4行目も同じ日になるようにします。1行目2行目と3行目4行目が同じ日にならないようにします。

下のは最終的に組み替えられた１つの結果になります。

2 2 2 7 4 4 4 3 3 1 1 1 6 6 5　…　1行目
1 1 1 7 2 2 2 6 6 5 3 3 4 4 4　…　2行目
4 4 4 5 7 3 3 2 2 2 6 6 1 1 1　…　3行目
3 3 6 6 7 5 1 1 1 4 4 4 2 2 2　…　4行目

この結果を含めて何パターンか高速に出力するプログラムをどのように書いたらいいか
教えて頂けると非常に助かります。

宜しくお願いします。

回答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

お礼

ありがとうございます。

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

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

回答No.6

nag0720

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

条件を満たす組み合わせは２００万通り以上ありますから、他の数値に変わるのは、かなり後のほうになります。

組み合わせのパターンがランダムに現れるようにしたいなら、＃４のほうがいいでしょう。
ただし、＃４のコードは重複チェックしていませんので、確率はかなり低いですが前と同じ組み合わせが出てくる可能性がありますので、それだけ注意してください。

＃５のコードでは、１行目と２行目を交換したもの、３行目と４行目を交換したもの、
さらに１,２行目と３,４行目を交換したものなどは同じものとみなしていますので、重複して出てくることはありません。
もしそれも違う組み合わせとして数えるなら、組み合わせの数は３０００万通り以上になります。

お礼

ありがとうございます。

おかげでやりたかったことが実現致しました。

回答No.4

ki-aaa

#3の回答者です。よく考えたら、#2の方法が簡単なので、
その方法を書きます。

Sub 総当り() 'この行から
Dim i As Long, j As Long, k As Long, n As Long
Dim Gyo1 As Long, Gyo2 As Long, Gyo3 As Long, Gyo4 As Long
Dim Retu1 As Long, Retu3 As Long
Dim 総組合表(0 To 7199, 0 To 14) As Long
Dim nnn As Long
Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long, i5 As Long, i6 As Long, i7 As Long
Dim 引数表(0 To 6) As Long
Dim 出力表(0 To 3, 0 To 14) As Long
Dim 組合せ As String

'**両端が"7"以外のすべての組合せを作る*3600できる***************************
'*パターン　111・222・333・44・5・66・7　***********************************

For i1 = 1 To 6
For i2 = 1 To 7
If i1 <> i2 Then
For i3 = 1 To 7
If i1 <> i3 And _
i2 <> i3 Then
For i4 = 1 To 7
If i1 <> i4 And _
i2 <> i4 And _
i3 <> i4 Then
For i5 = 1 To 7
If i1 <> i5 And _
i2 <> i5 And _
i3 <> i5 And _
i4 <> i5 Then
For i6 = 1 To 7
If i1 <> i6 And _
i2 <> i6 And _
i3 <> i6 And _
i4 <> i6 And _
i5 <> i6 Then
For i7 = 1 To 6
If i1 <> i7 And _
i2 <> i7 And _
i3 <> i7 And _
i4 <> i7 And _
i5 <> i7 And _
i6 <> i7 Then
n = 0
引数表(0) = i1
引数表(1) = i2
引数表(2) = i3
引数表(3) = i4
引数表(4) = i5
引数表(5) = i6
引数表(6) = i7
For i = 0 To 6
Select Case 引数表(i)
Case 1, 2, 3
総組合表(nnn, n) = 引数表(i)
総組合表(nnn, n + 1) = 引数表(i)
総組合表(nnn, n + 2) = 引数表(i)
n = n + 3
Case 4, 6
総組合表(nnn, n) = 引数表(i)
総組合表(nnn, n + 1) = 引数表(i)
n = n + 2
Case 5, 7
総組合表(nnn, n) = 引数表(i)
n = n + 1
End Select
Next i
nnn = nnn + 1
End If
Next i7
End If
Next i6
End If
Next i5
End If
Next i4
End If
Next i3
End If
Next i2
Next i1

For i = 0 To 3599
For j = 0 To 14
総組合表(i + 3600, j) = 総組合表(i, j)
Next j
Next i

Do
組合せ = "できた"
'************************一行目****************************

Gyo1 = Int(Rnd * 3600) '0から3599までの乱数
For j = 0 To 14
If 総組合表(Gyo1, j) = 7 Then
Retu1 = j
Exit For
End If
Next j
'************************二行目*****************************

i = Int(Rnd * 3600) '0から3599までの乱数
For Gyo2 = i To i + 3599
If 総組合表(Gyo2, Retu1) = 7 Then
For j = 0 To 14
If 総組合表(Gyo1, j) = 総組合表(Gyo2, j) Then
If Retu1 <> j Then Exit For
End If
Next j
If j > 14 Then Exit For
End If
Next Gyo2
If Gyo2 - i > 3599 Then 組合せ = "できず"
'************************三行目*****************************

i = Int(Rnd * 3600) '0から3599までの乱数
For Gyo3 = i To i + 3599
For j = 0 To 14
If 総組合表(Gyo3, j) = 7 Then
Retu3 = j
End If
If 総組合表(Gyo1, j) = 総組合表(Gyo3, j) Then Exit For
If 総組合表(Gyo2, j) = 総組合表(Gyo3, j) Then Exit For
Next j
If j > 14 Then Exit For
Next Gyo3
If Gyo3 - i > 3599 Then 組合せ = "できず"
'************************四行目*****************************

i = Int(Rnd * 3600) '0から3599までの乱数
For Gyo4 = i To i + 3599
If 総組合表(Gyo4, Retu3) = 7 Then
For j = 0 To 14
If 総組合表(Gyo1, j) = 総組合表(Gyo4, j) Then Exit For
If 総組合表(Gyo2, j) = 総組合表(Gyo4, j) Then Exit For
If 総組合表(Gyo3, j) = 総組合表(Gyo4, j) Then
If Retu3 <> j Then Exit For
End If
Next j
If j > 14 Then Exit For
End If
Next Gyo4
If Gyo4 - i > 3599 Then 組合せ = "できず"
'***********************************************************

Loop Until 組合せ = "できた"

For j = 0 To 14
出力表(0, j) = 総組合表(Gyo1, j)
出力表(1, j) = 総組合表(Gyo2, j)
出力表(2, j) = 総組合表(Gyo3, j)
出力表(3, j) = 総組合表(Gyo4, j)
Next j
Range("A" & Rows.Count).End(xlUp).Offset(3, 0).Resize(4, 15).Value = 出力表
End Sub 'この行まで

お礼

ありがとうございます。

教えて頂いたコードで短時間に結果を出力することができました。

おかげでやりたかったことが実現致しました。

回答No.3

ki-aaa

三日ごとに区切り、組み合わせを限定すればかなり簡略化できます。

たとえば、
１・・・コースA（連続して3日間）　　５・・・コースE（1日間）
２・・・コースB（連続して3日間）　　６・・・コースF（連続して2日間）
３・・・コースC（連続して3日間）　　７・・・コースG（1日間）
４・・・コースD（連続して2日間）

4は、5か7と組み合わせ3日間のとする
6は、5か7と組み合わせ3日間のとする

これで良ければ、できますよ。

お礼

ありがとうございます。

処理時間はかなり短縮できそうですね。
コースの受講日数が増減した場合はどうしたらいいのでしょうか。

回答No.2

nag0720

単純に計算すれば、７つのコースの並べ方は、７！＝５０４０通り
そのうち、両端がコースGにならない組み合わせは３６００通り

時間さえ気にしなければ、
この３６００通りから順に４つ選んで条件に合うものだけを出力すればいいでしょう。

高速にということであれば、
コースGが同じ日になる２つの組み合わせを３６００×３６００の中から選びんでリストを作り、さらにその中から条件に合う２組の組み合わせを調べればかなり時間短縮になるでしょう。

お礼

ありがとうございます。

もしよろしければ、どういうコードになるか教えて頂けないでしょうか。

回答No.1

DIooggooID

＞　例外として7のコースBだけは

　　この　"7のコースB"　とは、何のことですか？

＞　同じ日、　違う日　　とは　何のことですか？

　　"日"　の要素　は　どこに現れているのでしょう？？？

補足

> この　"7のコースB"　とは、何のことですか？

すみません、7のコースGの間違いです。

> "日"　の要素　は　どこに現れているのでしょう？？？

下記のように並べて左から1日目、2日目…と続き末尾は15日目になります。

【1日目】　　　　　　　　　　【15日目】
1 1 1 2 2 2 3 3 3 4 4 5 6 6 7

よろしくおねがいします。