VBA

<シート1>
B3〜B34に2020/1/1から2020/1/31までの日付、
C2〜C34には使った金額が書かれています。

<シート2>
B3からB5に1週間ごとの日付
ex)B3 2019/12/29
B4 2020/1/5

C2〜I2に曜日が書かれている表があります。

→該当するセルに金額を入力したい。



シート1のデータをシート2の表に転記のコマンドボタンを使用して転記したいですのですが、どうやったらいいかわかりません。教えて下さい。

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

• ご丁寧にありがとうございます。
  私の言葉不足だったのですが、シート2は以下のようになっています。
  　　（B）　　　　　　（C)（D)(E) (F) (G) (H) （I）
  ㅤㅤㅤㅤㅤㅤ　　　　　　日　月　火　水　木　金　土
  （3）2019/12/29
  （4）2020/1/5
  
  （）内はセルの縦列と横列です。
  シート1の2020/1/1に使った2000円をシート2の（F.3）に入れたいです。
  シート1の日付に応じた金額をシート2に入れたいです。説明が分かりにくくてすみません。
  
  折角長文で丁寧に送って下さったのにすみません。このような場合はどうしたらいいのでしょうか？

  No.1の回答に寄せられた補足コメントです。 補足日時：2020/11/28 09:55

• ありがとうございます。
  プログラムを実行することができました。
  ワークシート1が2020/1/1からのデータが書いてあるのですが、ワークシート2のB3は2019/12/29なので、2020/1/1〜2020/1/4までに数値が入っていません。どうしたら良いのでしょうか？

  No.2の回答に寄せられた補足コメントです。 補足日時：2020/11/28 15:22

No.1 ベストアンサー 回答者： ggrksdqn 回答日時： 2020/11/27 23:32

＜質問から推定される要件＞

1. シート2のB列の日付（"末日"）を上から順番に検査する
2. "末日"から6日間さかのぼった日（"初日"）の日付を求める
3. シート1のB列の日付を上から順に検査し、その日付が"初日"から"末日"の
間であれば、その行のC列の値を"合計"に加算する。.
4. シート2のC列に"合計"を入力する
5. シート2上に設けたコマンドボタンを押して、以上の処理を開始する

＜手順＞
1. 下のコードを標準モジュールに貼り付ける
2. シート２にコマンドボタンを配置する
[開発] - [挿入] - [フォームコントロール] - [ボタン]

3. 2で配置したボタンを右クリックし、[マクロの登録]で
"週ごとに集計して転記"を指定する

＜コードの例＞
'************************************************
'（注意）
'シート1のデータが日付昇順になっていない場合を考慮し､
'必ず先頭行から最終行まで検査するので､行数が多くなると時間がかかる
'************************************************
Public Sub 週ごとに集計して転記()

Const 履歴シート As String = "Sheet1"
Const 合計シート As String = "Sheet2"
Const 日付範囲1 As String = "B3:B33"
Const 日付範囲2 As String = "B3:B10"
Const 日付列から金額列までの距離 As Integer = 1
Const 日付列から合計列までの距離 As Integer = 2


Dim dateRng1 As Range, dateRng2 As Range

Set dateRng1 = ThisWorkbook.Sheets(履歴シート).Range(日付範囲1)
Set dateRng2 = ThisWorkbook.Sheets(合計シート).Range(日付範囲2)

Dim r1 As Range
For Each r1 In dateRng2

If Not IsDate(r1.Value) Then Exit For

Dim ed As Date: ed = r1.Value
Dim st As Date: st = DateAdd("d", -6, ed)

Dim r2 As Range, sum As Long

For Each r2 In dateRng1

If r2.Value >= st And r2.Value <= ed Then
sum = sum + r2.Offset(0, 日付列から金額列までの距離).Value
End If

Next

r1.Offset(0, 日付列から合計列までの距離) = sum
sum = 0

Next

End Sub

この回答へのお礼

丁寧に教えていただきありがとうございました。

お礼日時：2020/11/30 19:14

No.3 回答者： ggrksdqn 回答日時： 2020/11/28 17:21

No.1 からの修正

＜手順＞
1. 下のコードを標準モジュールに貼り付ける
2. シート２にコマンドボタンを配置する
[開発] - [挿入] - [フォームコントロール] - [ボタン]

3. 2で配置したボタンを右クリックし、[マクロの登録]で
"転記"を指定する

＜コードの例＞
Public Sub 転記()

Const 履歴シート As String = "Sheet1"
Const 日付検査範囲 As String = "B3:B33"

Const 転記先シート As String = "Sheet2"
Const キー日付範囲 As String = "B3:B9"

Dim dateRng1 As Range, dateRng2 As Range

Set dateRng1 = ThisWorkbook.Sheets(履歴シート).Range(日付検査範囲)
Set dateRng2 = ThisWorkbook.Sheets(転記先シート).Range(キー日付範囲)


'キー日付範囲 を １つずつ検査
Dim r As Range
Dim st As Long: st = 1 '検査開始行

For Each r In dateRng2

'当該行の金額入力範囲をクリア
Dim c As Integer: For c = 1 To 7: r.Offset(0, c) = "": Next

'キー日付セルの値が日付データでなければループを抜ける
If Not IsDate(r.Value) Then Exit For

'日付検査範囲 を １つずつ検査
Dim i As Long
For i = st To dateRng1.Rows.Count

'検査中のセルの値が日付データなら
If IsDate(dateRng1.Item(i)) Then

Dim keyDate As Date: keyDate = r.Value 'キー日付
Dim thisDate As Date: thisDate = dateRng1.Item(i) '検査中の日付

'検査中の日付がキー日付と同じ週に属する場合
If InSameWeek(keyDate, thisDate) Then

'キー日付の行、該当曜日の列に金額を転記する
r.Offset(0, Weekday(thisDate)) = dateRng1.Item(i).Offset(0, 1)

'この日が週の末尾（土曜日）なら
If Weekday(thisDate, vbSunday) = 7 Then

'1つ下の行を次の検査開始行にしてiループを抜ける
st = i + 1: Exit For

End If

End If

End If

Next i

Next

End Sub
'二つの日付が同じ週に属するか否かを返す
Public Function InSameWeek(date1 As Date, date2 As Date) As Boolean

Dim diff As Integer

diff = Weekday(date2, vbSunday) - 1

If date1 = DateAdd("d", -diff, date2) Then
InSameWeek = True
End If

End Function

No.2 回答者： ggrksdqn 回答日時： 2020/11/28 14:49

No.1 からの修正

＜手順＞
1. 下のコードを標準モジュールに貼り付ける
2. シート２にコマンドボタンを配置する
[開発] - [挿入] - [フォームコントロール] - [ボタン]

3. 2で配置したボタンを右クリックし、[マクロの登録]で
"転記"を指定する

＜コードの例＞
'************************************************
'（注意）
'　セル内のデータが日付かどうかのチェックは行わない
'　Sheet2のB列には日付が一つずつ連続して入力されおり、抜けや重複がないものとする
'************************************************
Public Sub 転記()

Const 履歴シート As String = "Sheet1"
Const 転記先シート As String = "Sheet2"
Const 日付範囲1 As String = "B3:B29"
Const 日付範囲2 As String = "B3:B9"

Dim dateRng1 As Range, dateRng2 As Range

Set dateRng1 = ThisWorkbook.Sheets(履歴シート).Range(日付範囲1)
Set dateRng2 = ThisWorkbook.Sheets(転記先シート).Range(日付範囲2)

Dim r1 As Range
For Each r1 In dateRng2

Dim i As Long
For i = 1 To dateRng1.Rows.Count

If dateRng1.Item(i) = r1.Value Then

Dim c As Long
For c = 0 To 6
r1.Offset(0, c + 1) = dateRng1.Item(i).Offset(c, 1)
Next

i = i + 7
If i > dateRng1.Rows.Count Then Exit For

End If

Next

Next

End Sub