エクセルVBAで次の様にデーターをテンプレートに反映したいのですが

バラシシートと短冊シートがあり、バラシシートのS列データーを短冊シートに記入していくようにしたいのですが、（短冊シートは罫線のテンプレートがつくってあります）1番から2，3，4とデーターを入れていきたいのですが、1つのボックスは10列2行の20個入るようになってますが、赤の矢印のように右上から右下に入れて行きます。そしてバラシシートのS列データーが空欄になれば1つのロットが終了となます。そこで、9のマスの様に1つのボックスを飛ばして、次のロットを10から始めるというようにしたいのです、　図を見て理解いただければ幸いです。

質問者からの補足コメント

• 教えて頂いた、鮮明画像です
  https://gyazo.com/88ac1329113fa8a6841b40a38c246757

    補足日時：2022/04/07 19:55

No.9 ベストアンサー 回答者： tatsumaru77 回答日時： 2022/04/08 18:09

>S列のデータは2行目から始まるようになってます。

画像をみると４行目からのように見えますが、バラシシートS列は２行目から開始といたします。

＞K7->B7です、打ち間違いでしょうが。
K7->M7は誤りです。失礼しました。K7->B7が正しいです。

＞後はセルの色も反映したいのですが。
了解しました。

以下のマクロを標準モジュールに登録してください。
最初に短冊シートA列のマス番号のチェックも行っています。
画像と同じ位置にないとエラーになります。

-------------------------------------------------------
Option Explicit

Dim sh1 As Worksheet 'バラシシート
Dim sh2 As Worksheet '短冊シート
Public Sub 短冊シート設定()
Dim maxrow1 As Long
Dim maxrow2 As Long
Dim max_box As Long
Dim i As Long
Dim wrow As Long
Dim boxNo As Long
Dim seqNo As Long
Dim box_row As Long
Dim box_col As Long
Set sh1 = Worksheets("バラシ")
Set sh2 = Worksheets("短冊")
maxrow1 = sh1.Cells(Rows.count, "S").End(xlUp).row 'S列の最大行取得
If maxrow1 < 4 Then Exit Sub
maxrow2 = sh2.Cells(Rows.count, "A").End(xlUp).row 'A列の最大行取得
If (maxrow2 + 1) Mod 4 <> 0 Then
MsgBox ("マス番号の行が不正")
Exit Sub
End If
max_box = (maxrow2 + 1) \ 2
'短冊シートのマスをクリア
For i = 1 To max_box
Call clear_box(i)
Next
'バラシシートを処理
boxNo = 1
seqNo = 0
For wrow = 2 To maxrow1
If sh1.Cells(wrow, "S").Value = "" Then
If seqNo > 0 Then
boxNo = boxNo + 2
seqNo = 0
End If
Else
seqNo = seqNo + 1
If seqNo > 20 Then
boxNo = boxNo + 1
seqNo = 1
End If
'マス番号とマス内番号に対応する位置を取得
Call get_pos_in_box(boxNo, seqNo, box_row, box_col)
'該当位置へS列データを設定
sh2.Cells(box_row, box_col).Value = sh1.Cells(wrow, "S").Value
sh2.Cells(box_row, box_col).Interior.Color = sh1.Cells(wrow, "S").Interior.Color
End If
Next
MsgBox ("完了")
End Sub

'指定マスクリア
Private Sub clear_box(ByVal box_no As Long)
Dim box_row As Long
Dim box_col As Long
Dim i As Long
For i = 1 To 20
Call get_pos_in_box(box_no, i, box_row, box_col)
sh2.Cells(box_row, box_col).ClearContents
sh2.Cells(box_row, box_col).Interior.Pattern = xlNone
Next
End Sub
'指定マスの位置取得
Private Sub get_box_pos(ByVal box_no As Long, ByRef start_row As Long, ByRef start_col As Long)
start_row = ((box_no - 1) \ 2) * 4 + 2
If box_no Mod 2 = 0 Then
start_col = 22
Else
start_col = 11
End If
End Sub
'マス内の位置取得
Private Sub get_pos_in_box(ByVal box_no As Long, ByVal seq_no As Long, ByRef box_row As Long, ByRef box_col As Long)
Dim start_row As Long
Dim start_col As Long
Call get_box_pos(box_no, start_row, start_col)
box_row = start_row
If seq_no > 10 Then
box_row = box_row + 1
seq_no = seq_no - 10
End If
box_col = start_col - seq_no + 1
End Sub

No.8 回答者： Qchan1962 回答日時： 2022/04/08 17:57

こんにちは、

試されるとの事なので、少し変更を

＞セルの色も反映したいのですが。
＃7のコード
短冊.Cells(rw, CInt(clm(i)) + a) = r.Value: i = i + 1　
を下記に変更してください

短冊.Cells(rw, CInt(clm(i)) + a) = r.Value
短冊.Cells(rw, CInt(clm(i)) + a).Interior.Color = r.Interior.Color
i = i + 1
とします。

If r.End(xlDown).Row - r.Row = 1 Then　なので
空欄が複数あっても（空欄が1つと）同じ処理がされます

ちなみに短冊シートの初期化は行っていないので
自動記録などを使って初期化するコードを初めに加える方が良いのかあも知れませんね。

No.7 回答者： Qchan1962 回答日時： 2022/04/08 13:07

＃３＃４です

マスエリアの左下に小さな数字をよく見ていませんでした。。
＃４を直せば出来ると思いますが、ついでに空白データが複数ある場合
無視して　エリア1つ　のみ飛ばす例を・・
当てずっぽな回答を何度もするのは、良くないと思っておりますが
リアクションがないですし、暇でしたのでお許しください。

Sub sample()
Dim バラシ As Worksheet: Set バラシ = Worksheets("バラシ")
Dim 短冊 As Worksheet: Set 短冊 = Worksheets("短冊")
Dim r As Range, clm As Variant, rw As Long, i As Integer
Dim a As Integer, sk
rw = 2
clm = Split("11, 10, 9, 8, 7, 6, 5, 4, 3, 2", ",")
For Each r In Range(バラシ.Cells(4, "S"), バラシ.Cells(Rows.Count, "S").End(xlUp))
If r <> "" Then
短冊.Cells(rw, CInt(clm(i)) + a) = r.Value: i = i + 1
If i = UBound(clm) + 1 Then
i = 0
If rw Mod 2 = 0 Then
rw = rw + 1
Else
If a = 0 Then a = 11: rw = rw - 1 Else: a = 0: rw = rw + 3
End If
End If
Else
i = 0
If r.End(xlDown).Row - r.Row = 1 Then
If rw Mod 2 = 0 Then rw = rw + 1
If rw Mod 2 <> 0 Then rw = rw + 3
End If
End If
Next
End Sub

この回答へのお礼

ありがとうございます。
試してみます

お礼日時：2022/04/08 17:39

No.6 回答者： tatsumaru77 回答日時： 2022/04/08 11:04

＞そしてバラシシートのS列データーが空欄になれば1つのロットが終了となます。

そこで、9のマスの様に1つのボックスを飛ばして、次のロットを10から始めるというようにしたいのです

S列データの空欄が2つ以上続くがありますか、
①空欄が2つ以上続くことはない。
②空欄が2つ以上続くことはある。
上記のどちらでしょうか。

もし、②の場合、その空欄の数ぶん、マスを飛ばすのですか。
例えば、空欄が２つの場合、９マス、１０マスを飛ばして、１１マスから始める。
それとも、空欄が２つ以上続いても、飛ばすのは９マスだけでしょうか。

この回答へのお礼

①空欄が2つ以上続くことはない。ようになってます。

お礼日時：2022/04/08 17:38

No.5 回答者： tatsumaru77 回答日時： 2022/04/08 08:46

No1です。

鮮明な画像のアップ、ありがとうございました。

補足要求です。
１．短冊シートのシート名は何でしょうか。
２．バラシシートのシート名は何でしょうか。
３．バラシシートのS列のデータは４行からでしょうか。
４．短冊シートの設定順序ですが、以下で間違いないですか。
①最初の２０件　：K2->B2、K3->B3
②　次の２０件　：V2->M2、V3->M3
③その次の２０件：K6->B6、K7->M7
以降、同様とする。

この回答へのお礼

シート名は短冊とバラシです、S列のデータは2行目から始まるようになってます。K7->B7です、打ち間違いでしょうが。
後はセルの色も反映したいのですが。

お礼日時：2022/04/08 17:36

No.4 回答者： Qchan1962 回答日時： 2022/04/07 22:40

＃３・・

条件出そろっていないけど・・・
空欄のセルが続くなんて言うのは無しで、、
（あるっぽいけど、、考える楽しみはお譲りいたします）

Sub reference_sample()
Dim バラシ As Worksheet: Set バラシ = Worksheets("バラシ")
Dim 短冊 As Worksheet: Set 短冊 = Worksheets("短冊")
Dim r As Range, clm As Variant, rw As Long, i As Integer
Dim a As Integer
rw = 2
clm = Split("22, 21, 20, 19, 18, 17, 16, 15, 14, 13", ",")
For Each r In Range(バラシ.Cells(4, "S"), バラシ.Cells(Rows.Count, "S").End(xlUp))
If r <> "" Then
短冊.Cells(rw, CInt(clm(i)) + a) = r.Value: i = i + 1
If i = UBound(clm) + 1 Then
i = 0
If rw Mod 2 = 0 Then
rw = rw + 1
Else
If a = 0 Then a = -11: rw = rw - 1 Else: a = 0: rw = rw + 3
End If
End If
Else
i = 0
If rw Mod 2 = 0 Then rw = rw + 1
If rw Mod 2 <> 0 Then rw = rw + 3
End If
Next
End Sub

ステップ実行で理解してください。（間違っていたらごめんなさい）

No.3 回答者： Qchan1962 回答日時： 2022/04/07 14:36

こんにちは

画像が見えないのですが、ご説明を解読・・すみません。
こんな感じの事かな？と想像でサンプルします。
不明条件がありますが、取敢えず考慮しません。

良く分からないので、対象範囲はバラシシートS列2行目から最終行
短冊シートはB2～K3　のエリアで2行飛びエリア

Sub reference_sample()
Dim バラシ As Worksheet: Set バラシ = Worksheets("バラシ")
Dim 短冊 As Worksheet: Set 短冊 = Worksheets("短冊")
Dim r As Range, clm As Variant, rw As Long, i As Integer
rw = 2
clm = Split("11, 10, 9, 8, 7, 6, 5, 4, 3, 2", ",")
For Each r In Range(バラシ.Cells(2, "S"), バラシ.Cells(Rows.Count, "S").End(xlUp))
If r <> "" Then
Cells(rw, CInt(clm(i))) = r
i = i + 1
If i = UBound(clm) + 1 Then
i = 0
If rw Mod 2 = 0 Then rw = rw + 1
If rw Mod 2 <> 0 Then rw = rw + 3
End If
Else
i = 0
If rw Mod 2 = 0 Then rw = rw + 8
If rw Mod 2 <> 0 Then rw = rw + 7
End If
Next
End Sub

No.2 回答者： めぐみん_ 回答日時： 2022/04/07 10:29

直接の回答ではありません。

画像の不鮮明については知恵袋にも質問を立てているようなので、そちらを見てみるしかないかも。
しかし内容的に何をしたいのかが私には良くわかりません。
多分業務で同僚に相談され話を聞きながらであれば解決するかもとは感じますけど。

No.1 回答者： tatsumaru77 回答日時： 2022/04/07 08:24

画像が不鮮明でよくわかりません。

gyazo.comへアップすれば、鮮明な画像を公開できます。
下記はサンプルです。（画像の内容は質問とは関係ありません）
https://gyazo.com/e87ac6702d9c90c980f2bf7fd0477952
gyazo.comへアップされてはいかがでしょうか。