祝日を除いた月曜から土曜までの1週間分の日付行を選択し、別シートへカットアンドペーストしたい

sh1のB列に縦に最大31日分の曜日が並んでいます。この列から最初の1週間分の曜日を祝日を除いて切り取り、Sh2に貼り付けるコードを教えてください。
行を指定して貼り付ける下記コードだと、例として火曜日が祝日だった場合、次の1週間分のシートが月曜始まりにならないため、月曜から土曜までの行を指定し、無い曜日があっても次の1週間分のシートができるようにしたいのですが、、、
findを使って検索し、切り取っていくようなイメージにするには、どのようなコードになるか教えてください。

With Sheets("sh1")
.Range(.Cells(1, "A"), .Cells(6, "AA")).Copy _
Destination:=Sheets("sh2").Range("A1")
End With

2023/07/03 (月)
2023/07/05 (水)
2023/07/06 (木)
2023/07/07 (金)
2023/07/08 (土)
2023/07/10 (月)
2023/07/11 (火)
2023/07/12 (水)
・・・・・
・・・・・
_______________
【Sh1】

2023/07/03 (月)
2023/07/05 (水)
2023/07/06 (木)
2023/07/07 (金)
2023/07/08 (土)
＿＿＿＿＿＿＿＿
【Sh2】

2023/07/10 (月)
2023/07/11 (火)
2023/07/12 (水)
・・・・・
・・・・・
＿＿＿＿＿＿＿
【sh3】

No.13 ベストアンサー 回答者： tatsumaru77 回答日時： 2023/07/17 17:47

どうも、こちらで確認した日付とあなたの環境の日付に齟齬が発生しているようです。

ソースを修正するためには、データ（日付）がどのようになっているかを正確に把握する必要があります。
>2023/07/03 (月)
>2023/07/04 (火)
>2023/07/05 (水)
>2023/07/06 (木)
>2023/07/07 (金)
>2023/07/08 (土)
この日付は、excelのsh1　B列をコピペしたものですか。それとも、手入力したものでしょうか。
2023/07/03と(月)の間に半角のスペースが１つありますが、それであってますか。（他の日付も同様）
又、(月)の後ろに半角又は全角の空白などがありませんか。

この回答へのお礼

ありがとうございます。シリアル値にするため、日付をいじっていたことが原因でした。お手数をおかけし申し訳ございませんでした。
助かりました！

お礼日時：2023/07/17 20:00

No.12 回答者： tatsumaru77 回答日時： 2023/07/17 17:31

こちらのSh1のA1:B15の範囲の画像です。

No.11 回答者： tatsumaru77 回答日時： 2023/07/17 17:29

>sh2へ1行だけ

>2023/07/03 (月)の行が転記され、
>sh3へ
>2023/07/04 (火)
>2023/07/05 (水)
>2023/07/06 (木)
>2023/07/07 (金)
>2023/07/08 (土)
>が転記委されるのは何故でしょう？

こちらの環境では、
sh2へ
2023/07/03 (月)
2023/07/04 (火)
2023/07/05 (水)
2023/07/06 (木)
2023/07/07 (金)
2023/07/08 (土)
が転記されています。
Sh1のA1:B15の範囲を画像にしてアップしていただけませんでしょうか。

No.10 回答者： tatsumaru77 回答日時： 2023/07/16 23:19

No9です。

もし、No9で、正常に動作した場合は、以下のことに注意してください。
sh1のB列の日付は、あなたが作成したのではなく、他の方が作成したということでしょうか。
そうであれば、今後も、今までと同じように日付を文字列で設定するように伝えてください。
もし、途中からシリアル日付を入力し、書式設定で曜日を表示するように変えてしまうと、マクロが動かなくなります。

No.9 回答者： tatsumaru77 回答日時： 2023/07/16 23:05

>セル：B2の「2023/07/03 (月)」の書式設定は

>「標準」でした

日付は、文字列として設定されていると解釈しました。
2023/07/03 (月)から（月）を除いた"2023/07/03"の文字列を
シリアル日付に変換し、処理を行うようにしました。

前回のマクロは、全て破棄して、こちらを登録してください。
Option Explicit
Public Sub 週次シフト作成()
Dim ms As Worksheet
Dim ws As Worksheet
Dim sh_names As Variant
Dim maxrow As Long
Dim wrow As Long
Dim row2 As Long
Dim i As Long
Dim sx As Long
Dim wstr As String
Dim wday As Date
Dim stday As Date: stday = 0
Dim prevday As Date
Dim wendday As Date
Set ms = Worksheets("sh1")
maxrow = ms.Cells(Rows.Count, 2).End(xlUp).Row
sh_names = Array("sh2", "sh3", "sh4", "sh5", "sh6", "sh7")
For i = 0 To UBound(sh_names)
Set ws = Worksheets(sh_names(i))
ws.Cells.Clear
ms.Cells(1, 1).Resize(1, 27).Copy Destination:=ws.Cells(1, 1)
Next
For wrow = 2 To maxrow
wstr = ms.Cells(wrow, "B").Value
wstr = left(wstr, Len(wstr) - 3)
If IsDate(wstr) = False Then
Call error_proc("日付不正", ms, wrow)
End If
wday = CDate(wstr)
If Weekday(wday) = 1 Then
Call error_proc("日曜日不正", ms, wrow)
End If
If stday = 0 Then
stday = wday
prevday = stday - 1
wendday = wday + 7 - Weekday(wday)
sx = 0
row2 = 2
End If
If Year(wday) = Year(stday) And Month(wday) = Month(stday) Then
Else
Call error_proc("年、月不正", ms, wrow)
End If
If wday <= prevday Then
Call error_proc("日付順序不正", ms, wrow)
End If
If wday > wendday Then
wendday = wday + 7 - Weekday(wday)
sx = sx + 1
row2 = 2
If sx > UBound(sh_names) Then
Call error_proc("シート数オーバー", ms, wrow)
End If
End If
Set ws = Worksheets(sh_names(sx))
ms.Cells(wrow, 1).Resize(1, 27).Copy Destination:=ws.Cells(row2, 1)
row2 = row2 + 1
prevday = wday
Next
MsgBox ("完了")
End Sub
'エラー処理
Public Sub error_proc(ByVal err_msg As String, ByVal ms As Worksheet, ByVal wrow As Long)
MsgBox (err_msg)
ms.Activate
ms.Cells(wrow, "B").Select
End
End Sub

この回答へのお礼

ありがとうございます。転記できました。
sh2へ1行だけ
2023/07/03 (月)の行が転記され、
sh3へ
2023/07/04 (火)
2023/07/05 (水)
2023/07/06 (木)
2023/07/07 (金)
2023/07/08 (土)
が転記委されるのは何故でしょう？
以降のシートはあ（月)～ (土)が転記されています？
ステップインしてみたところ、sh2へ2023/07/03 (月)の行を転記したあと、
ms.Cells(wrow, 1).Resize(1, 27).Copy Destination:=ws.Cells(row2, 1)
row2 = row2 + 1
でsh3へ移っていました。どのように変更したらよいかご教授いただけませんでしょうか。よろしくおねがいします。

お礼日時：2023/07/17 17:11

No.8 回答者： tatsumaru77 回答日時： 2023/07/16 20:51

No7の添付画像です。

こちらの環境のB列のセルの値と書式設定の内容です。

No.7 回答者： tatsumaru77 回答日時： 2023/07/16 20:43

No6です。

>B列の2行目から「2023/07/03 (月)」の形式で下に日付が並んでいるため、
>maxrow = ms.Cells(Rows.Count, 2).End(xlUp).Row
>としてみたところ、「日付不正」となりました。
>どこを修正したらよいか教えてください。

①maxrowについて
maxrow = ms.Cells(Rows.Count, 2).End(xlUp).Row
が正しいです。こちらで、試験時、A列とB列の行を同じにしておいたので、
ms.Cells(Rows.Count, 1)でも、動作してしまいました。
ms.Cells(Rows.Count, 2)に訂正いたします。

②「日付不正」の件
こちらでは、B列の日付は、以下の前提でマクロを作っています。
B列の日付はシリアル日付が設定され、セルの書式設定で
ユーザー定義で"yyyy/mm/dd(aaa)"を指定している。

そうすると、表示上　2023/07/01(土)　のように表示されます。

B列の内容が日付として妥当か否かのチェックをしています。
If IsDate(ms.Cells(wrow, "B").Value) = False Then
Call error_proc("日付不正", ms, wrow)
End If
の箇所でエラーとなり、"日付不正"のメッセージが表示されます。

どのようにB列に日付を設定していますか？
（何か関数などを使っていれば、それも含めて提示してください）

この回答へのお礼

ありがとうございます。セル：B2の「2023/07/03 (月)」の書式設定は
「標準」でした、ユーザー定義で"yyyy/mm/dd(aaa)"を指定したり、日付に変更してみましたが「シリアル値」ではないようなので転記できませんでした。予めB列をシリアル値へ変更しようとしましたが私の知識では無理でした。どのように変更したら良いか教えてください。

お礼日時：2023/07/16 21:18

No.6 回答者： tatsumaru77 回答日時： 2023/07/16 09:28

以下のマクロを標準モジュールに登録してください。

Option Explicit
Public Sub 週次シフト作成()
Dim ms As Worksheet
Dim ws As Worksheet
Dim sh_names As Variant
Dim maxrow As Long
Dim wrow As Long
Dim row2 As Long
Dim i As Long
Dim sx As Long
Dim wday As Date
Dim stday As Date: stday = 0
Dim prevday As Date
Dim wendday As Date
Set ms = Worksheets("sh1")
maxrow = ms.Cells(Rows.Count, 1).End(xlUp).Row
sh_names = Array("sh2", "sh3", "sh4", "sh5", "sh6", "sh7")
For i = 0 To UBound(sh_names)
Set ws = Worksheets(sh_names(i))
ws.Cells.Clear
ms.Cells(1, 1).Resize(1, 27).Copy Destination:=ws.Cells(1, 1)
Next
For wrow = 2 To maxrow
If IsDate(ms.Cells(wrow, "B").Value) = False Then
Call error_proc("日付不正", ms, wrow)
End If
wday = ms.Cells(wrow, "B").Value
If Weekday(wday) = 1 Then
Call error_proc("日曜日不正", ms, wrow)
End If
If stday = 0 Then
stday = wday
prevday = stday - 1
wendday = wday + 7 - Weekday(wday)
sx = 0
row2 = 2
End If
If Year(wday) = Year(stday) And Month(wday) = Month(stday) Then
Else
Call error_proc("年、月不正", ms, wrow)
End If
If wday <= prevday Then
Call error_proc("日付順序不正", ms, wrow)
End If
If wday > wendday Then
wendday = wday + 7 - Weekday(wday)
sx = sx + 1
row2 = 2
If sx > UBound(sh_names) Then
Call error_proc("シート数オーバー", ms, wrow)
End If
End If
Set ws = Worksheets(sh_names(sx))
ms.Cells(wrow, 1).Resize(1, 27).Copy Destination:=ws.Cells(row2, 1)
row2 = row2 + 1
prevday = wday
Next
MsgBox ("完了")
End Sub
'エラー処理
Public Sub error_proc(ByVal err_msg As String, ByVal ms As Worksheet, ByVal wrow As Long)
MsgBox (err_msg)
ms.Activate
ms.Cells(wrow, "B").Select
End
End Sub

この回答へのお礼

ありがとうございます。学ぶべき箇所が多くありがたいです。
For i = 0 Toでシートを指定するのは初めてです。
お示しいただいたコードを実行したところ、「完了」となりましたがシートへの転記はありませんでした。B列の2行目から「2023/07/03 (月)」の形式で下に日付が並んでいるため、
maxrow = ms.Cells(Rows.Count, 2).End(xlUp).Row
としてみたところ、「日付不正」となりました。
どこを修正したらよいか教えてください。
よろしくお願いします。

お礼日時：2023/07/16 19:41

No.5 回答者： tatsumaru77 回答日時： 2023/07/15 17:40

以下のようにしたいということでしょうか。

１．Sh1の月間のシフト表を以下のように振り分ける。
①Sh2へ第1週の月～土のシフト表を転記
②Sh3へ第2週の月～土のシフト表を転記
③Sh4へ第3週の月～土のシフト表を転記
④Sh5へ第4週の月～土のシフト表を転記
⑤Sh6へ第5週の月～土のシフト表を転記
⑥Sh7へ第6週の月～土のシフト表を転記
但し、月がなければ火、なければ水...となり、
終了は同じ週の土で、土がなければ金、無ければ木...となる。

理論上６週まであるので、シートはSh7まで確保します。

２．Sh1の１行目は見出し行でしょうか。
それとも、データがいきなり１行目から開始でしょうか。

３．Sh1のA列が日付、B列が曜日でしょうか。

４．Sh2～Sh7へ転記するのは、A列～AA列で間違いないでしょうか。

５．Sh1の日付の年、月は、全て同じであり、他の年月の日付は存在しないと理解しました。間違いないでしょうか。

この回答へのお礼

ありがとうございます。
1.のとおりです。
2.Sh1の１行目は見出し行になります。
3. Sh1のB列が日付(曜日)になっています。
4. Sh2～Sh7へ転記するのは、A列～AA列になります。
5. Sh1の日付の年、月は、全て同じです。
よろしくおねがいします。

お礼日時：2023/07/16 00:22

No.4 回答者： 初心者ですが何か。 回答日時： 2023/07/14 11:41

そう言えば月末も気になりますが。

結局【日曜日】が区切りになるようですので、その月の日曜日の前後の日付が START・STOP としてもイレギュラーは起きそうもないデータ群（日報？）でしょうか？

この回答へのお礼

確かにsh1には無い日曜日を区切りにするとスッキリしますね。使用する用途は、sh1が月次のシフト表で、週次で掲示用のシフトをsh1、sh2、sh3、sh4、sh5として作成しています。頻繁に週を跨いだ変更が発生し、手動でのコピペ作業が….助けてください。

お礼日時：2023/07/14 14:20