質問: エクセルで入力シートから別シートに蓄積方法について とある入力用シートをまとめて別シートに全て毎回手で入力しているのですが、 入力したデータを別シートの雛形に蓄積するという方法はありますでしょうか。 コピペというのも考えましたが、入力用シート自体はシートごとで保存していたら 膨大な量になってしまうので上書きで作成しているためコピペが出来ません。 例えば、 入力用シートにa22〜f22(日付や数・単価・金額(金額は数式入っています))を入力したら 蓄積用シートのa22〜f22にデータが反映され、 それが新たに入力用シートの同じ箇所(a22〜f22)に入力しても 蓄積用シートのa22〜f22以降の行に反映し蓄積出来るようにしたいです。 また、月ごとに蓄積用シートを変えれれば尚良いと思っています。 調べていたら関数では出来ないとのこと&今まで同様の質問をされていた内容を試して見たが出来なかったです。 マクロに挑戦してみようと思うのですが、全くの初心者です。 エクセルのバージョンは2016です。 方法がなければ諦めます。方法があればお教えください。 よろしくおねがいします。
回答: こんなものはいかがでしょうか? 1 現在存在するシートの名前を辞書に登録 2 入力用シートの22行目からのa列の日付を基に年月(シート名)を作成 3 2で作成したものが辞書に無かったら入力用シートをコピーしてシート名を年月に変えて22行目以降のa~f列を削除して空シートを作成しておきます(22行目以降のa~f列以外は書式を含めて残ります) 4 2~3を最後まで繰り返します(これで必要なシートが揃います) 5 一度辞書をクリアします 6 入力用シートの22行目からのa列の日付を基に年月(シート名)を作成 7 6で作成したものが辞書に無かったら、年月日シートに入力用シートの22行目以降のa~f列をコピーします。年月と合わない行のa~fのデータをクリア、あっている場合は念のためf列を再計算しておき、22行目以降をa列を基にソートを行い、その後不要な部分を削除します。 8 6~7を最後まで繰り返します。 9 入力用シートのデータをクリアします。(保存データ重複防止です) 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」にしています。