エクセルで入力シートから別シートに蓄積方法について

Question

とある入力用シートをまとめて別シートに全て毎回手で入力しているのですが、
入力したデータを別シートの雛形に蓄積するという方法はありますでしょうか。
コピペというのも考えましたが、入力用シート自体はシートごとで保存していたら
膨大な量になってしまうので上書きで作成しているためコピペが出来ません。

例えば、
入力用シートにA22〜F22(日付や数・単価・金額(金額は数式入っています))を入力したら
蓄積用シートのA22〜F22にデータが反映され、
それが新たに入力用シートの同じ箇所(A22〜F22)に入力しても
蓄積用シートのA22〜F22以降の行に反映し蓄積出来るようにしたいです。

また、月ごとに蓄積用シートを変えれれば尚良いと思っています。

調べていたら関数では出来ないとのこと＆今まで同様の質問をされていた内容を試して見たが出来なかったです。
マクロに挑戦してみようと思うのですが、全くの初心者です。

エクセルのバージョンは2016です。
方法がなければ諦めます。方法があればお教えください。
よろしくおねがいします。

GooUserラック · Accepted Answer

「Cells(Target.Row, 6).FormulaR1C1 = "=RC[-2]*RC[-1]"」は
「Cells(Target.Row, 6).FormulaR1C1 = "=IF(OR(RC[-2]="""",RC[-1]=""""),"""",RC[-2]*RC[-1])"」
の方が良いかもです。

GooUserラック · Answer

こんなものはいかがでしょうか？

① 印刷が終わると「データの転記とクリアを行いますか？」の確認が有ります「はい」ボタンを押すと先に進みます。「いいえ」ボタンを押すとキャンセルになり何もしないで終了します（印刷プレビューでの誤動作の後処理用）
② 現在存在するシートの名前を辞書に登録
③ 入力用シートの２２行目からのＡ列の日付を基に年月（シート名）を作成
④ ③で作成したものが辞書に無かったら、辞書に登録後、シートを追加しシート名を年月に変える、入力用シートをコピぺして２２行目以降のＡ～F列をクリア成しておきます（２２行目以降のＡ～F列以外は書式を含めて残ります）
⑤ ③～④を最後まで繰り返します（これで必要なシートが揃います）
⑥ 一度辞書をクリアします
⑦ 入力用シートの２２行目からのＡ列の日付を基に年月（シート名）を作成（データにあるシート名だけのリストを作成します）
⑧ ⑦で作成したものが辞書に無かったら、年月日シートに入力用シートの２２行目以降のＡ～Ｆ列を追加コピーします。年月と合わない行のＡ～Ｆのデータをクリア、あっている場合は念のためＦ列を再計算しておき、２２行目以降をＡ列を基にソートを行い、その後不要な部分を削除します。
⑨ ⑦～⑧を最後まで繰り返します。
⑩ 入力用シートのデータをクリアします。（保存データ重複防止です）

--------------------------------------------------------------------------------------
☆「入力用」へ　（注：①）
　　これでＤ列とＥ列に何か入力されるとＦ列に計算式がセットされるようになります。
--------------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)

　If Target.Row >= 22 Then
　　If Target.Column >= 4 Then
　　　If Target.Column <= 5 Then
　　　　Application.EnableEvents = False
　　　　Cells(Target.Row, 6).FormulaR1C1 = "=RC[-2]*RC[-1]"
　　　　Application.EnableEvents = True
　　　End If
　　End If
　End If

End Sub
--------------------------------------------------------------------------------------
☆「ThisWorkbook」へ　（注：②）
　　これで印刷開始後「転記」のマクロが起動します　
--------------------------------------------------------------------------------------
Private Sub Workbook_BeforePrint(Cancel As Boolean)

　Application.OnTime Now(), "転記"

End Sub
--------------------------------------------------------------------------------------
☆「標準モジュール」へ　（注：③）
--------------------------------------------------------------------------------------
Sub 転記()

Const 元シート名 As String = "入力用"
Dim シート辞書 As Object
Dim シート As Worksheet
Dim 終行番号 As Long
Dim 行番号 As Long
Dim 年月 As String
Dim 次行番号
Dim 次終行番号

　If MsgBox("データの転記とクリアを行いますか？", vbDefaultButton2 + vbYesNo) <> vbYes Then Exit Sub
　Sheets(元シート名).Select
　終行番号 = Cells(Rows.Count, 1).End(xlUp).Row
　If 終行番号 >= 22 Then
　　Set シート辞書 = CreateObject("Scripting.Dictionary")
　　For Each シート In Worksheets
　　　シート辞書.Add シート.Name, "元"
　　Next
　　For 行番号 = 22 To 終行番号
　　　年月 = Format(Cells(行番号, 1).Value, "yyyy_mm")
　　　If Not シート辞書.Exists(年月) Then
　　　　シート辞書.Add 年月, "新"
　　　　Sheets.Add After:=Sheets(Sheets.Count)
　　　　ActiveSheet.Name = 年月
　　　　Sheets("入力用").Cells.Copy
　　　　ActiveSheet.Paste
　　　　Range(Cells(22, 1), Cells(終行番号, 6)).ClearContents
　　　　Sheets(元シート名).Select
　　　End If
　　Next
　　シート辞書.RemoveAll
　　For 行番号 = 22 To 終行番号
　　　年月 = Format(Cells(行番号, 1).Value, "yyyy_mm")
　　　If Not シート辞書.Exists(年月) Then
　　　　シート辞書.Add 年月, "有"
　　　　次行番号 = Sheets(年月).Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　If 次行番号 < 22 Then 次行番号 = 22
　　　　Range(Cells(22, 1), Cells(終行番号, 6)).Copy Sheets(年月).Cells(次行番号, 1)
　　　　Sheets(年月).Select
　　　　Do While IsDate(Cells(次行番号, 1).Value)
　　　　　If 年月 <> Format(Cells(次行番号, 1).Value, "yyyy_mm") Then
　　　　　　Range(Cells(次行番号, 1), Cells(次行番号, 6)).ClearContents
　　　　　End If
　　　　　次行番号 = 次行番号 + 1
　　　　Loop
　　　　Range("A22:F" & 次行番号).Sort Key1:=Range("A22"), Order1:=xlAscending, Header:=xlNo
　　　　次行番号 = Cells(Rows.Count, 1).End(xlUp).Row
　　　　Rows(次行番号 & ":" & Rows.Count).Delete Shift:=xlUp
　　　　Cells(次行番号, 1).Select
　　　　Range("A1") = "請求書(蓄積用)"
　　　　次行番号 = ActiveSheet.UsedRange.Row
　　　　Sheets(元シート名).Select
　　　End If
　　Next
　　Range(Cells(22, 1), Cells(終行番号, 6)).ClearContents
　　Range("A22").Select
　　次行番号 = ActiveSheet.UsedRange.Row
　　Set シート辞書 = Nothing
　　MsgBox ("終了しました")
　Else
　　MsgBox ("データが有りませんでした")
　End If

End Sub
--------------------------------------------------------------------------------------
※（注：）は、図を参照してください。
※ Ｆ列目には計算式が入っている可能性が有るため、行の最後の判断材料にならなかったのでＡ列を使用しています。
　　（日付が無いデータはどこのシートに転写して良いか判らないので削除してます）
※「Const …」の「=」の右側は環境に合わせて変更して下さい。

GooUserラック · Answer

No.5 のお礼について

③ 行の最後はＦ列で判断すれば良いという事でしょうか？またＦ列で「空行」の判断をしても良いですか？
④⑤ それでしたら印刷したタイミングでの転記の方が間違いないと思いますがいかがでしょうか？
⑥ 題名とはどこのセルに入っているのですか？もしかしたら印刷時のヘッダーでしょうか？

GooUserラック · Answer

こんなものはいかがでしょうか？
① 現在存在するシートの名前を辞書に登録
② 入力用シートの２２行目からのＡ列の日付を基に年月（シート名）を作成
③ ②で作成したものが辞書に無かったら入力用シートをコピーしてシート名を年月に変えて２２行目以降のＡ～F列を削除して空シートを作成しておきます（２２行目以降のＡ～F列以外は書式を含めて残ります）
④ ②～③を最後まで繰り返します（これで必要なシートが揃います）
⑤ 一度辞書をクリアします
⑥ 入力用シートの２２行目からのＡ列の日付を基に年月（シート名）を作成
⑦ ⑥で作成したものが辞書に無かったら、年月日シートに入力用シートの２２行目以降のＡ～Ｆ列をコピーします。年月と合わない行のＡ～Ｆのデータをクリア、あっている場合は念のためＦ列を再計算しておき、２２行目以降をＡ列を基にソートを行い、その後不要な部分を削除します。
⑧ ⑥～⑦を最後まで繰り返します。
⑨ 入力用シートのデータをクリアします。（保存データ重複防止です）

Sub Sample()

Const 元シート名 As String = "入力用"

Dim シート辞書 As Object
Dim シート As Worksheet
Dim 終行番号 As Long
Dim 行番号 As Long
Dim 追行番号 As Long
Dim 年月 As String
Dim 次行番号 As Long
Dim 次終行番号 As Long

Sheets(元シート名).Select
　終行番号 = Cells(Rows.Count, 1).End(xlUp).Row
　If 終行番号 >= 22 Then
　　Set シート辞書 = CreateObject("Scripting.Dictionary")
　　For Each シート In Worksheets
　　　シート辞書.Add シート.Name, "元"
　　Next
　　For 行番号 = 22 To 終行番号
　　　年月 = Format(Cells(行番号, 1).Value, "yyyy_mm")
　　　If Not シート辞書.Exists(年月) Then
　　　　シート辞書.Add 年月, "新"
　　　　Sheets(元シート名).Copy After:=Sheets(Sheets.Count)
　　　　ActiveSheet.Name = 年月
　　　　Range(Cells(22, 1), Cells(Rows.Count, 6)).Delete Shift:=xlUp
　　　　Sheets(元シート名).Select
　　　End If
　　Next
　　シート辞書.RemoveAll
　　For 行番号 = 22 To 終行番号
　　　年月 = Format(Cells(行番号, 1).Value, "yyyy_mm")
　　　If Not シート辞書.Exists(年月) Then
　　　　シート辞書.Add 年月, "有"
　　　　次行番号 = Sheets(年月).Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　If 次行番号 < 22 Then 次行番号 = 22
　　　　Range(Cells(22, 1), Cells(終行番号, 6)).Copy Sheets(年月).Cells(次行番号, 1)
　　　　Sheets(年月).Select
　　　　次終行番号 = Cells(Rows.Count, 1).End(xlUp).Row
　　　　For 追行番号 = 次行番号 To 次終行番号
　　　　　If 年月 = Format(Cells(追行番号, 1).Value, "yyyy_mm") Then
　　　　　　Cells(追行番号, 6).Value = Cells(追行番号, 4).Value * Cells(追行番号, 5).Value
　　　　　Else
　　　　　　Range(Cells(追行番号, 1), Cells(追行番号, 6)).ClearContents
　　　　　End If
　　　　Next
　　　　Range("A22:F" & 追行番号).Sort Key1:=Range("A22"), Order1:=xlAscending, Header:=xlNo
　　　　次行番号 = Cells(Rows.Count, 1).End(xlUp).Row + 1
　　　　Rows(次行番号 & ":" & Rows.Count).Delete Shift:=xlUp
　　　　Cells(次行番号, 1).Select
　　　　次行番号 = ActiveSheet.UsedRange.Row
　　　　Sheets(元シート名).Select
　　　End If
　　Next
　　Range(Cells(22, 1), Cells(終行番号, 5)).ClearContents
　　Range("A22").Select
　　Set シート辞書 = Nothing
　　MsgBox ("終了しました")
　Else
　　MsgBox ("データが有りませんでした")
　End If

End Sub

※ シートは見つかった順に作成するので順番には並びません、必要ならば手動で入れ替えて下さい。
※ 自動では実行されません
※ 元シート名の「入力用」は状況に合わせて下さい。
※ 転送先のシート名は「yyyy_mm」にしています。

GooUserラック · Answer

なんとなく理解しました。
２２行目だけに入力されるわけではなく、その下の行に何行か入力していくわけですね？
（提案してしまったのは２２行目にだけに入力して、入力したらすぐ転記してしまうものです）
改めての確認です。
① 何行目まで入力できるとかの制限はありますか？
② 途中入力しない（空行）は存在しますか？もしあった場合は飛ばせば良いのですか？
③ 必ず入力される列はどこですか？（全てならそう回答ください）
④ 転記するタイミングは「保存」処理をしたときで良いですか？
⑤ 転記したらクリアして良いですよね？（転記した物が重複されないように）
⑥ 転記先も２２行目からとなっていますが、２１行目までも１度目はコピーした方が良いのでしょうか？
⑦ 転送先のシート名は「yyyy_mm」で良いですか？

GooUserラック · Answer

No.3 に対する返答が無かったので図の様な物を考えました。
次のようにしてお試しでテストしてみて下さい。

新規にブックを作成してシートを「入力用」だけにして「○○.xlsm」で保存して下さい。

図を参考に他の書式などもここで設定しておいてください。
[Enter]後のセル移動は「右」にして下さい
ちなみに G22セルはボタン風に見せる為、灰色の背景色、右と下に太い罫線引いておきます。
（判りやすくしているだけなので必ずしもこうでなくても構いません）
ここまでで一度保存しておきます。

「入力用」シートの「Worksheet_SelectionChange」に次のコードをコピペして下さい

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Address = "$G$22" Then
　　If IsDate(Range("A22").Value) Then
　　　Call 転写処理(Range("A22").Value)
　　End If
　End If

End Sub

「標準モジュール」に次のコードをコピペして下さい

Sub 転写処理(日付 As Date)

Dim シート名 As String
Dim シート As Worksheet
Dim シート有 As Boolean
Dim 次行 As Long

シート名 = Format(日付, "yyyy_mm")
　For Each シート In Worksheets
　　If シート.Name = シート名 Then シート有 = True
　Next
　If シート有 Then
　　Sheets(シート名).Select
　Else
　　Worksheets.Add(After:=Worksheets(1)).Name = シート名
　　Sheets("入力用").Range("A21:F21").Copy Range("A1")
　End If
　次行 = Cells(Rows.Count, 1).End(xlUp).Row + 1
　Sheets("入力用").Range("A22:F22").Copy
　Cells(次行, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
　Cells(次行, 1).PasteSpecial Paste:=xlPasteValues
　Cells.EntireColumn.AutoFit
　Sheets("入力用").Select
　Range("A22:E22").ClearContents
　Range("A22").Select

End Sub

ここで保存をして下さい。（後はご自由に…）

☆ 使い方

A22 ～ E22 まで入力し[Enter]キーで金額欄に移ります。
ここで入力に間違いがないか確認して下さい。
間違いが無ければ[Enter]キーで G22セルに移ると転写され A22～E22 がクリアされ A22 に移ります。
間違いが有った場合は修正後、数回[Enter]キーを押し G22セルまでもっていけば転写されます。
マウスなどの作業が不要でとても効率よいものになると思います。
（G22 セルを選択しても A22 セルに日付が無ければ転写は行われません）

GooUserラック · Answer

幾つか確認させてください。
① 入力用シートですが、Ｆ列以降は何か入力されていますか？
② 多分ですが入力後右のセルに移るように設定されていると思いますが間違いないでしょうか？
③ 日付はどこに記入されていますか？
④ 計算式はどこに入っていますか？
⑤ 入力後クリアした方が使いやすいと思うのですが、クリアしない方が良いところはありますか？

tom04 · Answer

こんばんは！

一例です。
標準モジュールにしてください。

Sub Sample1()
　Dim myRow As Long
　Dim wS As Worksheet

Set wS = Worksheets("蓄積用")
　　　If wS.Cells(Rows.Count, "A").End(xlUp).Row < 22 Then
　　　　myRow = 22
　　　Else
　　　　myRow = wS.Cells(Rows.Count, "A").End(xlUp).Row + 1
　　　End If
　　　With Worksheets("入力用").Range("A22").Resize(, 6)
　　　　.Copy
　　　　wS.Cells(myRow, "A").PasteSpecial Paste:=xlPasteValues
　　　　.SpecialCells(xlCellTypeConstants).ClearContents '//★//
　　　End With
End Sub

※　「入力用」シートのA22～F22を入力後マクロを実行してください。
※　値の貼り付けにしていますので、「蓄積用」シートの日付列の表示形式は好みの表示形式にしておいてください。
※　「入力用」シートのA22～F22のデータはコピー＆ペースト後、
数式が入っていないセルを消去するようにしています。
そのままデータを残したい場合は「★」の行を削除してください。