『ローテーション表作成のための基本表を作成したい』（さとこ新入社員）
立会ローテーションを、作成してます。
月 火 水 木 金
1 a b c d e 1 b c d e f 1 c d e f a 2 f a 2 a b 2 b c
と、ローテーションの１巡目がある場合に、 ２巡目〜１周するまでの１クール分の自動転記 って、できますか? １クールとは、全員が月曜日を担当する週分のこと
手作業で、とり急ぎ終わらせましたがもっと楽に作成を
したいと思いこの質問サイト見つけました。
ご教示宜しくお願いします
＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞
１．a,b,c,d,e,fはメンバーのお名前ですか
２．左端の１，２は何ですか
３．２ は 何故 火曜までしかないのでせうか
等々。。。たくさん アドバイスがあるとよいですね でわ
m(__)m
（隠居Z） 2025/07/10(木) 06:45:19
（匿名） 2025/07/10(木) 08:37:37
Dim baseCell As Range
Dim i As Long, j As Long, d As Long
Dim flatNames(1 To 15) As String
Dim rotatedNames(1 To 15) As String
Dim totalDays As Long: totalDays = 15 ' You can change this as needed
' 初期パターンの開始セル（B5）
Set baseCell = Range("B5")
' 初期パターン（B5:F7）を1次元配列に格納
Dim idx As Long: idx = 1
For i = 1 To 3
For j = 1 To 5
flatNames(idx) = Trim(baseCell.Offset(i - 1, j - 1).Value)
idx = idx + 1
Next j
Next i
' 各日ごとに1人ずつ右にローテーションして展開
For d = 0 To totalDays - 1
' ローテーション処理
For idx = 1 To 15
rotatedNames(((idx - 1 + d) Mod 15) + 1) = flatNames(idx)
Next idx
' 出力位置（B8以降、3行ずつ下へ）
For i = 1 To 3
For j = 1 To 5
Dim outRow As Long, outCol As Long
outRow = baseCell.row + 3 + d * 3 + (i - 1)
outCol = baseCell.Column + j - 1
Cells(outRow, outCol).Value = rotatedNames((i - 1) * 5 + j)
Next j
Next i
Next d
MsgBox totalDays & "日分のローテーションを展開しました！", vbInformation
End Sub
６人なので、翌週月曜日で１巡し火曜日はまた１番にもどります。なので、火曜日に前週の月曜日担当したメンバーが入ります。
そこから、ローテーションになるので火曜日〜２巡目が始まりこれを全員が月曜日担当するまで繰り返したものを自動作成したいです
（さとこ新入社員） 2025/07/10(木) 10:46:33
> １クールとは、全員が月曜日を担当する週分のこと というのがよくわからないですね。 質問の例では、d,eはまだ月曜を担当していないので、続くのですか？ そうなるところまで書かれたらどうですか？
「月曜を担当する」ということに注目する意味がわからないです。ルールなんでしょうけど。 ・全員が少なくとも一回は月曜を経験したらその組み合わせは即時終了なんですか？ ・そして新しい組み合わせを別途作成して、今度は火曜からスタートするんですか？ ・次は、火曜を全員が経験するまでとなるんですか？
提示されたコードはあなたが書かれたものですか？それは正しい結果をもたらすものなんですか？ どこまでが実現していて、まだ実現できていないところはどこか説明してもらえませんか？ （xyz） 2025/07/10(木) 12:07:42
こういう話では、 ・各人の担当回数が平等であることと、 ・メンバーができるだけ固定されないこと が注目される視点かと思います。
その例(全員で6人、1組は3人)で考えたら、ひとつずつずらしていく前提のもとでは、 6日でワンサイクルが終わるのですから、6日(の倍数)単位でものごとを考えれば、 皆さん同じ回数だけ担当することになるのではないですか? そこに月曜基準のようなものが入ってくるので理解がしにくいし、結果的に担当回数がブレることになります。
また、今の方式だとメンバーが固定されて、例えばaとdは同じ組になることはないわけですが、 それはaからfへの具体名割当てを実行し直すことで対応されようとしている と理解しました。（6日の倍数の適切なサイクルでされればよいでしょう）
# 単なる感想で失礼しました。 （xyz） 2025/07/10(木) 14:11:28
当初の表をもとに作成してみました。
これで合っていますか。
違っていたらスルーしてください。
|[A]|[B]|[C]|[D]|[E]
[1]|月 |火 |水 |木 |金
[2]|A |B |C |D |E
[3]|B |C |D |E |F
[4]|C |D |E |F |A
[5]|D |E |F |A |B
[6]|E |F |A |B |C
[7]|F |A |B |C |D
（隠居Z）さんの質問にも答えましょう。
（匿名） 2025/07/10(木) 15:13:58
匿名 さん
xyz さん
のご案内のようでしたら。無視して下さいね (*^^*)
Option Explicit
Private Sub AWWW()
Dim JMas(), jD(), dAry(), idx(), Dc
Dim i&, J&, k&, n&
Set Dc = CreateObject("Scripting.Dictionary")
JMas = Array("A", "B", "C", "D", "E", "F")
ReDim dAry(1 To 5)
J = 1
Do
dAry(J) = JMas(i)
If J = 1 Then
Dc(JMas(i)) = Empty
Debug.Print Dc.Count
End If
J = J + 1
i = i + 1
If J > UBound(dAry) Then
J = 1
ReDim Preserve idx(n)
idx(n) = dAry
ReDim dAry(1 To 5)
n = n + 1
If Dc.Count = 6 Then Exit Do
End If
If i > UBound(dAry) Then
i = 0
DoEvents
End If
Loop
With Worksheets(1)
.UsedRange.Clear
.Cells(1).Resize(UBound(idx) + 1, 5) = Application.Index(idx, 0, 0)
End With
Erase JMas, jD, dAry, idx
Dc.RemoveAll
End Sub
（隠居Z） 2025/07/10(木) 15:53:35
Dim mainList() As String, subList() As String, subsubList() As String
Dim week As Long, day As Long
Dim startRow As Long: startRow = 5
Dim daysPerWeek As Long: daysPerWeek = 5
Dim totalWeeks As Long
' M2セルから週数を取得
If IsNumeric(Range("M2").Value) Then
totalWeeks = CLng(Range("M2").Value)
Else
MsgBox "セル M2 に有効な週数（数値）を入力してください。", vbExclamation
Exit Sub
End If
' 表Aの名簿・サブ・サブサブを取得
mainList = GetNamesFromRange(Range("I12:W12"))
subList = GetNamesFromRange(Range("I13:W13"))
subsubList = GetNamesFromRange(Range("I14:W14"))
For week = 0 To totalWeeks - 1
For day = 0 To daysPerWeek - 1
Dim baseCol As Long: baseCol = 2 + day ' B列?F列
Dim baseRow As Long: baseRow = startRow + week * 3
Cells(baseRow, baseCol).Value = mainList((week * daysPerWeek + day) Mod (UBound(mainList) + 1))
Cells(baseRow + 1, baseCol).Value = subList((week * daysPerWeek + day) Mod (UBound(subList) + 1))
Cells(baseRow + 2, baseCol).Value = subsubList((week * daysPerWeek + day) Mod (UBound(subsubList) + 1))
Next day
Next week
MsgBox "M2セルの週数に従って、表Aの内容を転記しました！", vbInformation
End Sub
Function GetNamesFromRange(rng As Range) As String()
Dim cell As Range, tempList() As String
Dim count As Long: count = 0
For Each cell In rng
If Trim(cell.Value) <> "" Then
ReDim Preserve tempList(count)
tempList(count) = Trim(cell.Value)
count = count + 1
End If
Next cell
GetNamesFromRange = tempList
End Function
表Aを、作成すれば実現できるのでは？
（とおりすがり） 2025/07/10(木) 17:13:36
匿名さんへ。
2025/07/10(木) 15:13:58の以下のご発言についてお聞きします。 | ＞火曜日に前週の月曜日担当したメンバーが入ります。 | 当初の表ではそうなっていませんけど。 | 月曜日に前週の火曜日担当が入るの間違いでしょうか。
質問者さんの当初の表で、 第2週目の火曜日はa,b,cの3人の担当と表示されており、 これは第1週の月曜日の担当(a,b,c)と一致しています。 平仄は合っていると思います。何か誤認されていませんか?
質問者さんへ。
質問にあったケースが実際の前提なのか不明ですが、 そのケースでどういう結果になればいいのかを改めて明確に提示したほうが 話が進むと思います。
2025/07/10(木) 10:46:33で提示されたコードがどういう性格のものか知りませんが、 それぞれのメンバーの担当回数を調べてみれば、相当な偏りがあります。 されたいことは、簡単なコピーペイストでできることなので、 想定結果を示されることを推奨します。
そのうえで、 ・祝日対応なども必要なのか（7/21などの） ・ワンクール？期間だけでいいのかどうかも含めて、 仕様をもう少し丁寧に提示されたほうがよいと思います。
（xyz） 2025/07/11(金) 13:10:55
書き溜めておいたものを投稿して、私はここまでとします。 まあ、"基本表"ですから細かいことは気にしないことにしました。
A1:F1セルに6人のメンバーを書き、 A4セルに、以下の式を、数式バーに貼り付けて下さい。 スピルして結果が表示されるはずです。 (投稿の都合上、半角スペースが入っていますので、 最初の半角スペースだけ入れないようにしてコピーして下さい。）
=LET(
fn,LAMBDA(rng,rotation,必要人数,
LET(n,COUNTA(rng),
s,SEQUENCE(1,n),
m,MOD(s + rotation -1,n) + 1,
TAKE(INDEX(rng,1,m),1,必要人数)
)
),
rng,$A$1:$F$1,
必要人数,3,
クール,31,
d,REDUCE("",SEQUENCE(1,クール,0,1),
LAMBDA(accum,x,VSTACK(accum, fn(rng,x,必要人数)))),
TRANSPOSE(DROP(d,1))
)
どこまでがワンクールの終わりなのか不明だったので、長めにとって、31日にしてあります。 （全員が月曜を担当するようになった週の月曜までなのか、その週末までなのか（たぶん後者？））
【シートレイアウト】
A列 B C D E F ・・・・以下列名略
1 a b c d e f
2
3 月 火 水 木 金 月 火 水 木 金 月 火 水 木 金 月 火 水 木 金 月 火 水 木 金 月 火 水 木 金 月
4 a b c d e f a b c d e f a b c d e f a b c d e f a b c d e f a
5 b c d e f a b c d e f a b c d e f a b c d e f a b c d e f a b
6 c d e f a b c d e f a b c d e f a b c d e f a b c d e f a b c
こんな式を作っておいて、 ・あとは別の箇所に値貼り付けし、 ・それを実際の担当表にカットアンドコピーすればよいでしょう。 それくらは手でやっても大したことないです。(まあ全体が簡単なコピペですけどね） （xyz） 2025/07/11(金) 15:02:06
（匿名） 2025/07/12(土) 08:56:16
勘違いならすみませんが、
匿名さんは、複数のニックネームを変えながら投稿されているようにお見受けします。
特定のニックネームでは揶揄されていらっしゃる時も。
そういう時は大概、質問の読み取り違いだったりしますが、
指摘を受けると訂正されていらっしゃいますよね。
それには感心致しますが、一歩進んで、
もう少し落ち着いて、質問を読み解いてみてはいかがでしょう。
さすれば揶揄されることも減るのではありませんか。
（unknown） 2025/07/12(土) 09:29:09
?@表Ａ 1 2 3 4 5 6 7 8 9 10 11 12
メイン 熊本 秋田 大阪 長野 静岡 仙台 熊本 横浜 大阪 長野 静岡 仙台 サブ 大阪 静岡 仙台 熊本 横浜 秋田 大阪 長野 仙台 熊本 横浜 秋田 サブサブ 静岡 熊本 横浜 秋田 大阪 長野 静岡 仙台 横浜 秋田 大阪 長野
基本ローテーション表
週 月 火 水 木 金
1 熊本 秋田 大阪 長野 静岡
1 大阪 静岡 仙台 熊本 横浜
1 静岡 熊本 横浜 秋田 大阪
2 仙台 熊本 横浜 大阪 長野
2 秋田 大阪 長野 仙台 熊本
2 長野 静岡 仙台 横浜 秋田
3 静岡 仙台 熊本 秋田 大阪
3 横浜 秋田 大阪 静岡 仙台
3 大阪 長野 静岡 熊本 横浜
4 長野 静岡 仙台 熊本 横浜
4 熊本 横浜 秋田 大阪 長野
4 秋田 大阪 長野 静岡 仙台
5 大阪 長野 静岡 仙台 熊本
5 仙台 熊本 横浜 秋田 大阪
5 横浜 秋田 大阪 長野 静岡
6 秋田 大阪 長野 静岡 仙台
6 静岡 仙台 熊本 横浜 秋田
6 熊本 横浜 秋田 大阪 長野
7 熊本 横浜 大阪 長野 静岡
7 大阪 長野 仙台 熊本 横浜
7 静岡 仙台 横浜 秋田 大阪
8 仙台 熊本 秋田 大阪 長野
8 秋田 大阪 静岡 仙台 熊本
8 長野 静岡 熊本 横浜 秋田
9 静岡 仙台 熊本 横浜 大阪
9 横浜 秋田 大阪 長野 仙台
9 大阪 長野 静岡 仙台 横浜
10 長野 静岡 仙台 熊本 秋田
10 熊本 横浜 秋田 大阪 静岡
10 秋田 大阪 長野 静岡 熊本
11 大阪 長野 静岡 仙台 熊本
11 仙台 熊本 横浜 秋田 大阪
11 横浜 秋田 大阪 長野 静岡
12 横浜 大阪 長野 静岡 仙台
12 長野 仙台 熊本 横浜 秋田
12 仙台 横浜 秋田 大阪 長野
担当者により回数の隔たりがあるのは今回のマクロ質問には関係ないので考えなくてよいです。
こちらの事情なので・・・（おじさん少な目、若手多め、おじさんのうち２人は「２人で１人分」なので隔週）
最終的に、作成したいのはこの基本ローテーション表です。返信遅くなり大変申し訳ありませんでした
（さとこ新入社員） 2025/07/13(日) 11:15:32
Sub Macro1()
Dim v
Dim i&, j&, r&, c&, w&
Dim rng As Range
v = Range("B2:M4") '表Aのデータ部分範囲（見出しを除いた範囲）
Set rng = Range("A6") '基本ローテーション表の左上セル
w = 1
r = 1
c = 1
rng.Resize(, 5).Offset(, 1) = Array("月", "火", "水", "木", "金")
Do While w < 12
For i = 1 To 12
rng.Resize(3).Offset(r, c) = Application.Index(v, , i)
c = c + 1
If c > 5 Then
rng.Resize(3).Offset(r) = w
r = r + 3
c = 1
w = w + 1
End If
Next
Loop
End Sub
（unknown） 2025/07/13(日) 13:46:45
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.