Excelシートのデータを複数シートに一括転送したい

質問

こんばんは。

店舗コード　名称　　金額
１００　　　ＰＣ1　　１０，０００
１００　　　ＰＣ2　　１０，０００
２００　　　ＰＣ3　　２０，０００
３００　　　ＰＣ4　　３０，０００

上記のようなデータがシート1にあるとして、店舗コード毎に他のシートにデータを転送したいと思っています。
例えばシート2には店舗コード１００のデータ↓

店舗コード　名称　　金額
１００　　　ＰＣ1　　１０，０００
１００　　　ＰＣ2　　１０，０００

同じようにシート3には２００のデータ、シート4には３００のデータ・・・というようにしたいのですが、できますでしょうか？
可能であれば教えて下さい。
宜しくお願い致します。

回答No.3

KenKen_SP · ベストアンサー

> もう一件教えて頂きたいのですが、店舗コード別ではなくロケコード別等
> 最初の見出しを変える場合は式のどこを変更すれば良いでしょうか？

お礼欄に「できた」とありますが、補足欄とどちらのコメントが先(´・ω・`)?
追加質問が後という前提で回答しますね。

#1 のコードのうち

　　　　' 見出し行を取得します
　　　　Set rMidasi = Range("A1:C1")

ここで見出しの範囲を設定してます。したがって、実際は A1～J1 が見出しなら

　　　　' 見出し行を取得します
　　　　Set rMidasi = Range("A1:J1")

のように変更します。次に

　　　　' 店舗コードのセル参照
　　　　Set rCode = Sh.Cells(i, "A")

ここで、A 列の店舗コードを参照しています。ロケコードというものが、例えば
F 列にあるなら、

　　　　' ロケコードのセル参照
　　　　Set rCode = Sh.Cells(i, "F")

のように修正します。

> 何度も申し訳ありません。

別に構いませんよ。それよりも折角なので、無理のない範囲で結構ですから
マクロのカスタマイズにチャレンジしてみてほしい...と思います。

キー列を切り替えるのに都度コードを修正するのは面倒なので、一歩踏み込んで
マクロ実行時にどの列でシートを切り分けるか問い合わせて、指定できるように
してみて下さい。

参考）INPUTBOX を使います。これをどこに入れたら良いか...考えてみて下さい。

sCol = InputBox("A～C のどれか１文字を半角で入力して下さい", "シート切り分けのキー列指定")
If sCol = "" Then Exit Sub

～（略）～

' キー列のセル参照
Set rCode = Sh.Cells(i, sCol)

回答No.2

KenKen_SP

> マクロは・・・どのように設定すればいいのでしょうか？

【マクロの貼り付け方】
1.　Excel 画面で[Alt]+[F11]キーを押す
　　Visual Basic Editor (以下 VBE )起動
2.　VBE 画面で[挿入]-[標準モジュール]をクリック
3.　#1 の「Sub 店舗コード別にシート切り分け()」 から 「End Sub」の行を
　　コピーし、2. の操作で開いたスペースに貼り付け
4.　VBE を閉じる

【実行準備】
> 上記のようなデータがシート1にあるとして、店舗コード毎に他のシートに
> データを転送したいと思っています。

とありましたので、データのあるシート名は「シート1」にしてます。Sheet1
などに変更したい場合は、#1 のコードのうち以下の部分を修正して下さい。
なお、修正は VBE で行います。

　　' データシート参照
　　Set Sh = ThisWorkbook.Sheets("シート1")

マクロを実行すると、店舗コードに対応したシートを自動で挿入していきますの
で、予め用意する必要はありません。

【実行手順】
1.　Excel 画面で[ツール]-[マクロ]-[マクロ] から実行します。

【注意点】
このマクロはデータシート「シート1」にあるデータを既に転記済みであるか
どうかを問わずに全て店舗コード別に対応するシートに振り分けます。

つまり、一度シートに振り分けたら「シート1」の内容をクリアしておかないと
古いデータが重複して転記される恐れがあるので、運用に注意して下さい。

文章にすると大変そうですが、一度やってしまえばたいした作業ではありません。
では、頑張って下さい。

# マクロではなく、オートフィルターによる方法もご提案しました。
# こちらもご検討下さい。

お礼

で、できました～!!!!!!
ご丁寧に教えて頂き本当に感謝です。
例では少量のデータでしたが実際は膨大なデータ数なのでオートフィルタではめんどうだなと思っていました。
式の内容はわかりませんが、もっと勉強したいと思います。
本当にありがとうございました。

補足

ごめんなさい。
もう一件教えて頂きたいのですが、店舗コード別ではなくロケコード別等最初の見出しを変える場合は式のどこを変更すれば良いでしょうか？
何度も申し訳ありません。

回答No.1

KenKen_SP

こんにちは。KenKen_SP です。

▼　提案 1
　　オートフィルターで店舗コード毎にそれぞれ抽出したデータを
　　コピーして、シートに貼り付け
　　長所：目視しながらの作業なので確実、重複データを誤って貼り付けても
　　　　　「やり直し」ボタンで元に戻せる
　　短所：件数が多いと面倒

　　# そもそもオートフィルターという便利な機能があるので、シートに切り
　　# 分ける必要は無い気もします。後々のデータ加工で面倒になりますよ。

▼　提案 2
　　マクロによる解決(参考コード)
　　長所：マクロ実行のボタンポッチで完了する。楽ちん。
　　短所：現状では既に転記済みかどうかを判定するフラグがないので
　　　　　誤って複数回マクロを実行すると重複転記の危険性がある。
　　　　　やり直しはできない。<-- 重要なのでご注意を

' 場所は「標準モジュール」

Sub 店舗コード別にシート切り分け()

　　Dim Sh　　　As Worksheet
　　Dim lRownum As Long
　　Dim i　　　 As Long
　　Dim rCode　 As Range
　　Dim rDest　 As Range
　　Dim rMidasi As Range

　　' データシート参照
　　Set Sh = ThisWorkbook.Sheets("シート1")
　　With Sh
　　　　' 見出し行を取得します
　　　　Set rMidasi = Range("A1:C1")
　　　　' データ最終行を求めます
　　　　lRownum = .UsedRange(.UsedRange.Cells.Count).Row
　　End With

　　Application.ScreenUpdating = False

　　' データ2行目から最終行までループ
　　For i = 2 To lRownum
　　　　' 店舗コードのセル参照
　　　　Set rCode = Sh.Cells(i, "A")
　　　　If rCode.Text <> "" Then
　　　　　　On Error GoTo ERROR_NOEXIST_SHEET
　　　　　　' 転記先セルを参照
　　　　　　' エラー発生ならシートがないので、エラーハンドラに
　　　　　　' 飛ばしてシートを追加してリトライ
　　　　　　Set rDest = ThisWorkbook.Sheets(Trim$(rCode.Text)) _
　　　　　　　　　　　　.Cells(Rows.Count, "A").End(xlUp).Offset(1)
　　　　　　On Error GoTo 0
　　　　　　' 行全体をコピーして転記
　　　　　　rCode.EntireRow.Copy Destination:=rDest
　　　　End If
　　Next i
　　' 後始末
　　Sh.Activate
　　Set rDest = Nothing:　 Set rCode = Nothing
　　Set rMidasi = Nothing: Set Sh = Nothing
　　Application.ScreenUpdating = True
　　MsgBox "終わったみたい(´・ω・`)", vbInformation
　　' 終了
　　Exit Sub

ERROR_NOEXIST_SHEET:
　　' シートが存在しない場合のエラーハンドラ
　　Err.Clear
　　On Error Resume Next
　　With ThisWorkbook.Worksheets.Add(After:=Sheets(ThisWorkbook.Sheets.Count))
　　　　.Name = Trim$(rCode.Value)
　　　　rMidasi.Copy Destination:=.Cells(1, "A")
　　End With
　　If Err Then
　　　　' ここでエラーが再び発生するようなら店舗コードがシート名として
　　　　' 相応しくないデータである...かも。 -->強制終了
　　　　MsgBox Err.Description, vbCritical
　　　　End
　　Else
　　　　' エラーをクリアしてリトライ
　　　　Err.Clear
　　　　Resume
　　End If
End Sub

補足

お忙しい中ご回答ありがとうございます。
マクロは・・・どのように設定すればいいのでしょうか？
何もわからなくてすみませんが教えて下さい。
宜しくお願いします。