XPのVBAで、シフトを組もうとしています。
登録者の中から5名を1組とし、班長を固定して4通り。
それを毎月、4組作成したいのです。
繰返しが多いので、簡単な方法がありそうなのですができません。
どうぞよろしくお願いいたします。
Sub 名簿()
Dim a As Range
‘名簿シートの1行目に=RAND()関数を入れる。2行目に名簿を作成する。
‘組合せシートの$AI$1, $AI$3, $AC$1, $AC$3の4つのセルに”組1”という名前を定義
‘名簿シートのB2セルの人を班長として固定。組合せシートの”組1”(4箇所)に貼り付ける
Sheets("名簿").Select
Range("B2").Select
Selection.Copy
Sheets("組合せ").Select
For Each a In Range("組1")
a.Select
ActiveSheet.Paste
Next a
‘名簿シートのC2セルから2行の最後までのデータをランダムに並べ替え、C2からF2をコピー、貼付け
For Each a In Range("組1")
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
以上の作業を”組2”、”組3”、”組4”においても繰り返したいのです。
できれば、組の中で同じ組合せがないほうが嬉しいのですが。
できれば班長も同じ組が出来ないほうがよいのですが。
ややこしいお話で申し訳ありませんが、よろしくおお願いいたします。
No.3ベストアンサー
- 回答日時:
こんにちは。
音沙汰がないので、サンプルのコードだけ提示します。
ステップ実行しながら処理を理解し、必要な処理を組み込んだり修正すれば目的の処理には、近づくと思います。
がんばってください。
【ステップ実行の仕方(釈迦に説法かもしれませんが……)】
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 = "MS ゴシック"
.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
- 回答日時:
こんにちは。
> 1点目は、この動作を組2、組3、組4においても繰り返したいのです
> が、4回繰り返して書く方法以外に、簡潔な書き方があれば教えてくだ
> さい。
前回も書きましたが、質問者さんだけが分かる情報を持っていて、回答
者側が分からない状態では、回答しようがありません。
一般的には、共通する処理をサブルーチン化して呼び出すような処理にするか、
Sub Hogehoge()
Call Hogehoge2("組1")
Call Hogehoge2("組2")
Call Hogehoge2("組3")
Call Hogehoge2("組4")
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("組1","組2","組3","組4")
For Each a In Sheets("組合せ").Range(XXX)
処理
Next a
Next XXX
End Sub
のような書き方ができると思います。
質問者さんが「簡潔な書き方」を何を指しておっしゃっているのか分か
りませんが、同じような処理を4回繰り返して書かないことが「簡潔な書
き方」だとすれば、まず、4回繰り返して処理を書いて、共通できる処理
とそうでない処理を割り出すことから始めたら如何でしょうか。
> 2点目は、………のRange("B2")の値が、4組の中で繰り返し出てこない
> ようにしたいのです。
コピー範囲と、貼付済み範囲のデータが同じかどうか総当たりで調べ、同
じにならなくなるまでコピー範囲の並べ替えを繰り返してから、貼付すれ
ばいいのではないでしょうか。
No.1
- 回答日時:
こんにちは。
とりあえず、提示されたコードを編集してみました。
Select、Selectionを使っていないので読みやすいと思います。
具体的なデータが提示されていないので動作の検証は、質問者さんが行ってください。
組1だけでなく、組2、3,4も行いたいとのことですが、データをどのように使うのかが回答したい側に伝わっていないので回答は控えさせていただきます。
編集したコードを見れば、質問者さんがどこをどう修正すればいいのか、見えてくるのではないかと思います。
ではでは。
Sub 名簿を編集()
Dim a As Range
'名簿シートの1行目に=RAND()関数を入れる。2行目に名簿を作成する。
'組合せシートの$AI$1, $AI$3, $AC$1, $AC$3の4つのセルに”組1”という名前を定義
'名簿シートのB2セルの人を班長として固定。組合せシートの”組1”(4箇所)に貼り付ける
Sheets("名簿").Range("B2").Copy Destination:=Sheets("組合せ").Range("組1")
'名簿シートのC2セルから2行の最後までのデータをランダムに並べ替え、C2からF2をコピー、貼付け
For Each a In Sheets("組合せ").Range("組1")
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点目は、この動作を組2、組3、組4においても繰り返したいのですが、4回繰り返して書く方法以外に、簡潔な書き方があれば教えてください。
2点目は、
Sheets("名簿").Range("B2").Copy Destination:=Sheets("組合せ").Range("組1")
のRange("B2")の値が、4組の中で繰り返し出てこないようにしたいのです。
どうぞよろしくお願いいたします。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) マクロで最終行を取得してコピーしたい 3 2022/04/06 19:07
- Excel(エクセル) ②Excel 簡単にシートコピーしたら前日の残高と日付を変更させたい→マクロの記録でエラーが出ます 8 2022/07/16 20:40
- Visual Basic(VBA) データのある範囲を選択するVBAについて 2 2022/09/03 00:20
- Excel(エクセル) エクセルのマクロでコピー後の貼り付け先を毎回指定したところにしたい 5 2022/08/12 10:47
- Excel(エクセル) エクセル VBAでシートのコピーを作りたい 1 2023/05/18 07:42
- Visual Basic(VBA) Excel_マクロ_現在開いているシートにマクロを実行したいです 1 2023/02/14 23:54
- Visual Basic(VBA) エクセル VBA 処理スピードを上げたいのですが。 6 2023/03/31 20:52
- Excel(エクセル) vbaで列幅について 1 2022/11/15 08:31
- Visual Basic(VBA) 動きっぱなしです。止め方とプロシージャの間違いを教えて下さい! 5 2022/08/15 23:08
- Excel(エクセル) VBAのoffsetの動き方について教えてください 3 2022/11/25 23:36
関連するカテゴリからQ&Aを探す
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
Vba SelStart、SelLen教えてく...
-
現在のブックを閉じないで、マ...
-
ExcelVBA シート名を複数セルか...
-
ユーザーフォームに別シートか...
-
【VBA】マクロの入ったファイル...
-
VBA listBoxから
-
VBAコンボボックスで選択した値...
-
VBA初心者 Ctrl+での操作、ボタ...
-
VBA実行後に元のセルに戻りたい
-
Excel-VBAのmsgBox()の不思議
-
エクセルのマクロについて教え...
-
FileCopy時のエラー
-
Excelのマクロでワードのテキス...
-
【ExcelVBA】インデックスが有...
-
Outlookの「受信日時」「送信者...
-
VBAで各列の"+"と"o"の合計数を...
-
エクセルのマクロについて教え...
-
エクセルのマクロについて教え...
-
エクセルのマクロについて教え...
-
エクセルのマクロについて教え...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
VBAのコードを教えてください
-
【ExcelVBA】インデックスが有...
-
ExcelVBA シート名を複数セルか...
-
エクセルvbaについて
-
エクセルのマクロについて教え...
-
【VBA】マクロの入ったファイル...
-
VBA UserFormからの転記で
-
エクセルVBAの配列について
-
Excelで「Ctrl+c」、「Ctrl+v...
-
VBAコードについて教えてくださ...
-
ExcelのVBAコードについて教え...
-
Excel マクロについての相談
-
VBAで質問があります
-
VBAコードについて
-
【ExcelVBA】VBA実行でダイアロ...
-
Excel関数またはVBAでの質問に...
-
ExcelのVBAコードについて教え...
-
ExcelのVBAコードについて教え...
-
ExcelのVBAコードについて教え...
-
Outlookの「受信日時」「件名」...
おすすめ情報