エクセル VBA 各シートへの振分け（転記）についてご教授願います。 ■集計シートB列からJ列に集計

エクセル VBA 各シートへの振分け（転記）についてご教授願います。

■集計シートB列からJ列に集計テーブルがあります

■3行目が項目行で最終行は増減します

■D列に曜日／H列に確認欄があります

■集計シートの右横から月曜日～日曜日までの曜日シートがあります

■各曜日シートは1行目が項目行で、集計シートと同じ項目がB列～H列まであります（I列J列は転記不要）

■各曜日シートの表はシート名同じテーブル名でテーブル化されています。
（例：月曜日sheet=月曜日テーブル）

■D列の曜日ごとで尚且つH列が空白の行を、各曜日シートへ振分け（転記）をしたいと思います

このプログラム（コード）を教えて下さい。
どうぞ宜しくお願い致します。

No.2 回答者： GooUserラック 回答日時： 2020/02/02 12:48

とりあえず、こんな感じではいかがでしょうか？

Sub Sample()

Dim シート As Worksheet
Dim 終 As Long
Dim 行 As Long
　
　For Each シート In Worksheets
　　Select Case シート.Name
　　　Case "日曜日", "月曜日", "火曜日", "水曜日", "木曜日", "金曜日", "土曜日"
　　　　Sheets("集計シート").Select
　　　　終 = Cells(Rows.Count, 4).End(xlUp).Row
　　　　Range(Cells(3, 2), Cells(Cells(Rows.Count, 4).End(xlUp).Row, 8)).Copy
　　　　シート.Select
　　　　Range("A1").Select
　　　　ActiveSheet.Paste
　　　　終 = 終 - 2
　　　　For 行 = 2 To 終
　　　　　If Cells(行, 3).Value <> シート.Name Then Range(Cells(行, 1), Cells(行, 7)).ClearContents
　　　　　If Cells(行, 7).Value <> "" Then Range(Cells(行, 1), Cells(行, 7)).ClearContents
　　　　Next
　　　　Cells.Sort Key1:=Range("C2"), Order1:=xlAscending, Header:=xlYes, Orientation:=xlTopToBottom
　　　　Rows(Cells(Rows.Count, 3).End(xlUp).Row + 1 & ":" & Rows.Count).Delete Shift:=xlUp
　　　　行 = ActiveSheet.UsedRange.Row
　　End Select
　Next
End Sub

この回答へのお礼

ありがとうございます。
先程帰宅した為に、お返事が遅くなってしまい大変申し訳ありません。
教えて下さったコードで理想通りの結果となりました。
本当に助かりました。
心より感謝申し上げます。
どうもありがとうございました。

お礼日時：2020/02/03 00:12

No.1 回答者： GooUserラック 回答日時： 2020/02/02 02:53

転記の際、各曜日シートの元々あるデータの処理は次のどれですか？

① 全クリアしてから転記
② どこかの列をキーにしてデータを更新（集計シートのキーとなる列を提示して下さい）
③ 元データは残したまま、追記
④ その他（具体的に説明して下さい）

曜日(D)列のデータはどうなっていますか？
⑤「月曜日」～「日曜日」
⑥「月」～「日」
⑦ 日付のデータで書式設定を「aaa」や「aaaa」にして表示している
　（数式バーには「yyyy/m/d」で表示される）
⑧ その他（具体的に説明して下さい）

「（I列J列は転記不要）」となってますが、H列も空欄なので不要なのでは？
⑨ 書式を含めて転記なので必要
⑩ 不要
⑪ その他（具体的に説明して下さい）

この回答へのお礼

ありがとうございます。
ご指摘の通り下記の説明が抜けておりましたので、質問して下さって助かりました。

【回答】
転記の際、各曜日シートの元々あるデータの処理は次のどれですか？
① 全クリアしてから転記
（ここは重要でしたね）

曜日(D)列のデータはどうなっていますか？
⑤「月曜日」～「日曜日」

「（I列J列は転記不要）」となってますが、H列も空欄なので不要なのでは？
⑩ 不要
（ご指摘の通りH列は不要でした）

大変お手数お掛け致しました。
また何か不明な点がありましたらご指摘下さい。
ご回答を心よりお待ちしております。

お礼日時：2020/02/02 09:25