For Eachを使った並び替えについて

質問

ＸＰのＶＢＡで、シフトを組もうとしています。
登録者の中から5名を１組とし、班長を固定して4通り。
それを毎月、４組作成したいのです。
繰返しが多いので、簡単な方法がありそうなのですができません。
どうぞよろしくお願いいたします。

Sub 名簿()
Dim a As Range
‘名簿シートの1行目に＝RAND()関数を入れる。2行目に名簿を作成する。
‘組合せシートの$AI$1, $AI$3, $AC$1, $AC$3の4つのセルに”組1”という名前を定義
‘名簿シートのB2セルの人を班長として固定。組合せシートの”組１”（4箇所）に貼り付ける
Sheets("名簿").Select
Range("B2").Select
Selection.Copy
Sheets("組合せ").Select
For Each a In Range("組１")
a.Select
ActiveSheet.Paste
Next a
‘名簿シートのC2セルから2行の最後までのデータをランダムに並べ替え、C2からF2をコピー、貼付け
For Each a In Range("組１")
a.Select
Selection.Offset(0, -4).Select
Sheets("名簿").Select
Range("C1:I2").Select
Selection.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
Range("C2:F2").Copy
Sheets("組合せ").Select
ActiveSheet.Paste
Next a
‘名簿シートの全てのデータをランダムに並び替え。
Sheets("名簿").Select
Range("B1:I2").Select
Selection.Sort Key1:=Range("C1"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight, SortMethod _
:=xlPinYin, DataOption1:=xlSortNormal
End Sub

以上の作業を”組２”、”組３”、”組４”においても繰り返したいのです。
できれば、組の中で同じ組合せがないほうが嬉しいのですが。
できれば班長も同じ組が出来ないほうがよいのですが。
ややこしいお話で申し訳ありませんが、よろしくおお願いいたします。

回答No.3

OtenkiAme · ベストアンサー

こんにちは。

　音沙汰がないので、サンプルのコードだけ提示します。
　ステップ実行しながら処理を理解し、必要な処理を組み込んだり修正すれば目的の処理には、近づくと思います。
　がんばってください。

【ステップ実行の仕方（釈迦に説法かもしれませんが……）】
　Alt+F8でマクロ（返事がないので）を選択し、編集ボタンをクリックします。
　VBEのコードウィンドウがアクティブになりますから、コードとワークシートが見えるように位置を変更します。
　［F8］を押す度にと1行ずつ処理を実行していきます。
　その処理が何を意味しているのか、どんな値を判定しているのか理解するのに役立ちます。

Sub 返事がないので()
'サンプルブックに8個のデータを作成し、
'班長が重複しない4組の、
'班長が固定された4つのグループを作成する

Dim OldSheetsCount As Long　'現在の新規ブックのシート数
Dim NewBook As Workbook '新規ブック
Dim mySht As Worksheet '"Sheet1"ワークシート
Dim NameListRange As Range '名前リスト範囲
Dim NameArea As Variant '各名前定義範囲
Dim Target As Range '名前定義したセル
Dim LeaderRange As Range '班長セル
Dim SortRange As Range '並べ替え範囲
Dim CopyRange As Range 'コピー範囲
Dim CountOfCopy 'コピー回数

'------------------------------------------------------------
'新規でサンプルブックを作成
With Application
　　OldSheetsCount = .SheetsInNewWorkbook
　　.SheetsInNewWorkbook = 1
　　.Calculation = xlCalculationManual
End With
Set NewBook = Workbooks.Add
Application.SheetsInNewWorkbook = OldSheetsCount
Set mySht = NewBook.Worksheets(1)
With mySht
　　.Range("E4,E6,K4,K6").Name = "Kumi1"
　　.Range("E8,E10,K8,K10").Name = "Kumi2"
　　.Range("E12,E14,K12,K14").Name = "Kumi3"
　　.Range("E16,E18,K16,K18").Name = "Kumi4"
　　Set NameListRange = .Range("A2:H2")
　　With NameListRange
　　　　Set LeaderRange = .Range("A1")
　　　　Set SortRange = .Resize(2).Offset(-1)
　　　　Set CopyRange = .Resize(, 4).Offset(, 1)
　　　　.Font.Name = "ＭＳ ゴシック"
　　　　.HorizontalAlignment = xlCenter
　　　　.Offset(-1).Value = "=RAND()"
　　End With
　　For Each Target In NameListRange
　　　　With Target
　　　　　　.Value = Replace(Left(.Address, 3), "$", Mid(.Address, 2, 1))
　　　　　　.Interior.ColorIndex = .Column + 32
　　　　End With
　　Next Target
'------------------------------------------------------------
'各名前定義に対する処理
'　　For Each NameArea In Array("Kumi1", "Kumi2", "Kumi3", "Kumi4")
'　　　　For Each Target In .Range(NameArea)
'　　　　　　Target.Resize(, 5).Offset(, -4).Clear
'　　　　Next Target
'　　Next NameArea
　　For Each NameArea In Array("Kumi1", "Kumi2", "Kumi3", "Kumi4")
　　　　Application.Calculate
　　　　SortRange.Sort Key1:=SortRange.Range("A1"), _
　　　　　　Header:=xlNo, Orientation:=xlLeftToRight
'------------------------------------------------------------
'班長の転記
'CopyDataCheckを呼び出し、班長範囲と各名前定義範囲の
'データが重複していないか調べ、
'重複していなければ班長を転記
'重複していたら、並べ替える
　　　　Do
　　　　　　If CopyDataCheck(CopyRange:=LeaderRange, _
　　　　　　　　CheckRange:=Union(.Range("Kumi1").Range("A1"), _
　　　　　　　　　　　　　　　　.Range("Kumi2").Range("A1"), _
　　　　　　　　　　　　　　　　.Range("Kumi3").Range("A1"), _
　　　　　　　　　　　　　　　　.Range("Kumi4").Range("A1")), _
　　　　　　　　　　　　　　　　　　CheckPosition:=0) = False Then
　　　　　　　　LeaderRange.Copy Destination:=.Range(NameArea)
　　　　　　　　Exit Do
　　　　　　Else
　　　　　　　　Application.Calculate
　　　　　　　　SortRange.Sort Key1:=SortRange.Range("A1"), _
　　　　　　　　　　Header:=xlNo, Orientation:=xlLeftToRight
　　　　　　End If
　　　　Loop
'------------------------------------------------------------
'班長以外の転記
'CopyDataCheckを呼び出し、コピー範囲と名前定義範囲の
'データが重複していないか調べ、
'重複していなければコピー範囲を転記
'重複していたら並べ替える
　　　　CountOfCopy = 0
　　　　For Each Target In .Range(NameArea)
　　　　　　Do
　　　　　　　　If CopyDataCheck(CopyRange:=CopyRange, _
　　　　　　　　　　CheckRange:=.Range(NameArea), _
　　　　　　　　　　　　　　　　CheckPosition:=-1) = False Then
　　　　　　　　　　CopyRange.Copy Destination:=Target.Offset(0, -4)
　　　　　　　　　　CountOfCopy = CountOfCopy + 1
　　　　　　　　　　Exit Do
　　　　　　　　Else
　　　　　　　　　　Application.Calculate
　　　　　　　　　　With SortRange
　　　　　　　　　　　　With .Resize(, .Columns.Count - 1).Offset(, 1)
　　　　　　　　　　　　　　.Sort Key1:=.Range("A1"), Header:=xlNo, _
　　　　　　　　　　　　　　Orientation:=xlLeftToRight
　　　　　　　　　　　　End With
　　　　　　　　　　End With
　　　　　　　　End If
　　　　　　Loop
　　　　　　If CountOfCopy = .Range(NameArea).Cells.Count Then
　　　　　　　　Exit For
　　　　　　End If
　　　　　　Application.Calculate
　　　　　　With SortRange
　　　　　　　　With .Resize(, .Columns.Count - 1).Offset(, 1)
　　　　　　　　　　.Sort Key1:=.Range("A1"), Header:=xlNo, _
　　　　　　　　　　Orientation:=xlLeftToRight
　　　　　　　　End With
　　　　　　End With
　　　　Next Target
　　Next NameArea
　　For Each NameArea In Array("Kumi1", "Kumi2", "Kumi3", "Kumi4")
　　　　.Range(NameArea).Value = _
　　　　　　"LD:" & .Range(NameArea).Range("A1").Value
　　Next NameArea
End With
'------------------------------------------------------------
'エクセルの設定及びオブジェクト変数の後始末
NameListRange.Offset(-1).Clear
Application.Calculation = xlCalculationAutomatic
Set CopyRange = Nothing
Set SortRange = Nothing
Set LeaderRange = Nothing
Set NameListRange = Nothing
Set mySht = Nothing
Set NewBook = Nothing

End Sub

Function CopyDataCheck(ByVal CopyRange As Range, _
　　CheckRange As Range, CheckPosition As Long) As Boolean
'指定されたコピー範囲とチェック範囲（名前定義した範囲の領域）
'に同じデータがあるか、総当りで調べて結果を返す関数
'全部同じ=>True、同じではない=>Falseを返す

Dim CopyR As Range 'コピー範囲の各セル
Dim CheckR As Range 'チェック範囲の各セル
Dim SameDataCount As Long　 '同じデータ数
Dim i As Long '列カウンタ

'------------------------------------------------------------
'重複データはないと回答（仮定）しておく
CopyDataCheck = False
For Each CheckR In CheckRange
　　If CheckR.Offset(, CheckPosition).Value <> "" Then
　　　　SameDataCount = 0
　　　　For Each CopyR In CopyRange
　　　　　　For i = 1 To CopyRange.Cells.Count
　　　　　　　　If CopyR.Value = CheckR.Offset(, _
　　　　　　　　　　　　　　　　i * CheckPosition).Value Then
　　　　　　　　　　SameDataCount = SameDataCount + 1
　　　　　　　　End If
　　　　　　Next i
　　　　Next CopyR
　　　　If SameDataCount = CopyRange.Cells.Count Then
　　　　　　'すべて重複データだったと回答する
　　　　　　CopyDataCheck = True
　　　　　　Exit Function
　　　　End If
　　End If
Next CheckR

End Function

お礼

何度もありがとうございました。なにもかもお世話になってありがとうございます。思ったよりレベルが高く、戸惑っていますが、教えていただいたコードにじっくり取り組んで、完成させたいと思います。本当にありがとうございました。これまでこれほど責任をもって取り組んでいただいたことはなく、感動しています。お返事が遅くなって申し訳ありませんでした。

回答No.2

OtenkiAme

こんにちは。

> １点目は、この動作を組２、組３、組４においても繰り返したいのです
> が、４回繰り返して書く方法以外に、簡潔な書き方があれば教えてくだ
> さい。
　前回も書きましたが、質問者さんだけが分かる情報を持っていて、回答
者側が分からない状態では、回答しようがありません。

　一般的には、共通する処理をサブルーチン化して呼び出すような処理にするか、
Sub Hogehoge()
　Call Hogehoge2("組１")
　Call Hogehoge2("組２")
　Call Hogehoge2("組３")
　Call Hogehoge2("組４")
End Sub
Sub Hogehoge2(ByVal NameRange As String)
　Dim a As Range
　For Each a In Sheets("組合せ").Range(NameRange)
　　　処理
　Next a
End Sub

For Each .. In .. Nextを使うことになると思います。
Sub Hogehoge()
Dim XXX As Variant
Dim a As Range
For Each XXX In Array("組１","組２","組３","組４")
　　For Each a In Sheets("組合せ").Range(XXX)
　　　　処理
　　Next a
Next XXX
End Sub
のような書き方ができると思います。

　質問者さんが「簡潔な書き方」を何を指しておっしゃっているのか分か
りませんが、同じような処理を４回繰り返して書かないことが「簡潔な書
き方」だとすれば、まず、４回繰り返して処理を書いて、共通できる処理
とそうでない処理を割り出すことから始めたら如何でしょうか。

> ２点目は、………のRange("B2")の値が、4組の中で繰り返し出てこない
> ようにしたいのです。
コピー範囲と、貼付済み範囲のデータが同じかどうか総当たりで調べ、同
じにならなくなるまでコピー範囲の並べ替えを繰り返してから、貼付すれ
ばいいのではないでしょうか。

回答No.1

OtenkiAme

こんにちは。

　とりあえず、提示されたコードを編集してみました。
　Select、Selectionを使っていないので読みやすいと思います。
　具体的なデータが提示されていないので動作の検証は、質問者さんが行ってください。

　組１だけでなく、組２、３，４も行いたいとのことですが、データをどのように使うのかが回答したい側に伝わっていないので回答は控えさせていただきます。

　編集したコードを見れば、質問者さんがどこをどう修正すればいいのか、見えてくるのではないかと思います。
　ではでは。

Sub 名簿を編集()

Dim a As Range
'名簿シートの1行目に＝RAND()関数を入れる。2行目に名簿を作成する。
'組合せシートの$AI$1, $AI$3, $AC$1, $AC$3の4つのセルに”組1”という名前を定義

'名簿シートのB2セルの人を班長として固定。組合せシートの”組１”（4箇所）に貼り付ける
Sheets("名簿").Range("B2").Copy Destination:=Sheets("組合せ").Range("組１")

'名簿シートのC2セルから2行の最後までのデータをランダムに並べ替え、C2からF2をコピー、貼付け
For Each a In Sheets("組合せ").Range("組１")
　　Sheets("名簿").Range("C1:I2").Sort _
　　　　Key1:=Sheets("名簿").Range("C1"), Order1:=xlAscending, _
　　　　Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
　　　　Orientation:=xlLeftToRight, SortMethod:=xlPinYin, _
　　　　DataOption1:=xlSortNormal
　　Sheets("名簿").Range("C2:F2").Copy Destination:=a.Offset(0, -4)
Next a

'名簿シートの全てのデータをランダムに並び替え。
Sheets("名簿").Range("B1:I2").Sort _
　　Key1:=Sheets("名簿").Range("C1"), Order1:=xlAscending, _
　　Header:=xlGuess, OrderCustom:=1, MatchCase:=False, _
　　Orientation:=xlLeftToRight, SortMethod:=xlPinYin, _
　　DataOption1:=xlSortNormal

End Sub

補足

早速、正確で親切な回答をありがとうございます。
いつも質問の仕方が悪く叱られているので、大変うれしく思いました。本当にありがとうございました。

早速動作の確認をしましたが、命令が簡潔で、スピードも速くできました。

ついでに、もう2点ほど教えていただきたいことがあるのですが、よろしければお願いいたします。甘えてしまって申し訳ありません。

1点目は、この動作を組２、組３、組４においても繰り返したいのですが、４回繰り返して書く方法以外に、簡潔な書き方があれば教えてください。

２点目は、
Sheets("名簿").Range("B2").Copy Destination:=Sheets("組合せ").Range("組１")
のRange("B2")の値が、4組の中で繰り返し出てこないようにしたいのです。

どうぞよろしくお願いいたします。