エクセルVBA シートにある日付１週間分転記

質問

お世話になります、Sheet1,Range(”A3")からFirstRow、Range(”A")にナンバーSheet1Range(”B")に日付Range(”C")に曜日Range(”D3")に会社名Range(”E")に行先名があります。
Sheet1Range(”B")にある日付１週間分をsheet2～sheet8に転記。sheet2には今日の日付をsheet3には翌日の日付を～sheet8までそれぞれ１週間分転記し、これを１日ごとクリアーかデリートしてから更新する構文をどなたかご教示お願いします。

回答No.2

kkkkkm · ベストアンサー

> シート６にデータが入ってましてシート７～シート１３が１週間の各日に表示するようにしたいのです

シートの順番で転記するものとシート名を指定して転記するものを記載していますので、どちらかを都合のいい方を試してみてください。

'シートの順番で
Sub Example()
Dim c As Range
Dim i As Integer, LastRow As Long

For i = 7 To 13 '７番目～１３番目シート
Sheets(i).Cells.ClearContents
Next
With Sheets("シート６") '実際のシート名に変更
For Each c In .Range(.Cells(3, "B"), .Cells(Rows.Count, "B").End(xlUp))
If c.Value2 >= Date And c.Value2 < DateAdd("d", 7, Date) Then
i = c.Value2 - Date + 7 '←この数値が転記先シートの最初のシートの左端からの番目
LastRow = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
Sheets(i).Cells(LastRow + 1, "A").Resize(1, 5).Value = .Cells(c.Row, "A").Resize(1, 5).Value
End If
Next
End With
End Sub

'シート名を指定する場合
Sub Example2()
Dim c As Range
Dim i As Integer, LastRow As Long
Dim MySheetName As Variant

MySheetName = Array("シート７", "シート８", "シート９", "シート１０", "シート１１", "シート１２", "シート１３")
'実際のシート名に変更　左から今日、明日、明後日・・・が転記される
For i = 0 To 6
Sheets(MySheetName(i)).Cells.ClearContents
Next
With Sheets("シート６") '実際のシート名に変更
For Each c In .Range(.Cells(3, "B"), .Cells(Rows.Count, "B").End(xlUp))
If c.Value2 >= Date And c.Value2 < DateAdd("d", 7, Date) Then
i = c.Value2 - Date
LastRow = Sheets(MySheetName(i)).Cells(Rows.Count, "A").End(xlUp).Row
Sheets(MySheetName(i)).Cells(LastRow + 1, "A").Resize(1, 5).Value = .Cells(c.Row, "A").Resize(1, 5).Value
End If
Next
End With
End Sub

お礼

シート名を指定して実行する方を選びました・
有難うございました。

回答No.1

kkkkkm

sheet2～sheet8が左端から2番目～8番目と順に並んでいるものとして(シート名は問いません)以下でいかがでしょう。

標準モジュールに
Sub Example()
Dim c As Range
Dim i As Integer, LastRow As Long

For i = 2 To 8
Sheets(i).Cells.ClearContents
Next
With Sheets("Sheet1")
For Each c In .Range(.Cells(3, "B"), .Cells(Rows.Count, "B").End(xlUp))
If c.Value2 >= Date And c.Value2 < DateAdd("d", 7, Date) Then
i = c.Value2 - Date + 2
LastRow = Sheets(i).Cells(Rows.Count, "A").End(xlUp).Row
Sheets(i).Cells(LastRow + 1, "A").Resize(1, 5).Value = .Cells(c.Row, "A").Resize(1, 5).Value
End If
Next
End With
End Sub

お礼

有難うございました

補足

申し訳ございません、シート２～シート８ではなくシート６にデータが入ってましてシート７～シート１３が１週間の各日に表示するようにしたいのです。間違ったことをお詫びします。再度ご教示お願いします、宜しくお願いします