Excelでリストを分割して保存

Pocket

Excelで作成した在庫リストを支店別のファイルに分割したい場合のマクロです。Excel2007で動作を確認しました。

「全体リスト」シート

元となる「全体リスト」です。
この表を別のファイルにコピーし、支店ごとに、必要な行だけを残して、保存します。

A B C D
1 整理番号 支店 商品 数量
2 10 札幌 500
3 20 札幌 1,100
4 30 札幌 1,700
5 40 仙台 2,300
6 50 仙台 700
7 60 仙台 1,300
8 70 福島 1,900
9 80 福島 900
10 90 千葉 1,500
11 100 千葉 2,100

「支店リスト」シート

分割の対象となる「支店リスト」です。ここに挙げられた支店名についてファイルを作成します。

A
1 札幌
2 仙台
3 福島
4 千葉

マクロ(VBA)

Sub リスト分割()
    Const zentai_row_top = 2 '全体リストのレコードの最初の行
    Const zentai_row_bottom = 11 '全体リストのレコードの最後の行
    Const zentai_col_siten = 2 '全体リストの支店名がある列
    Const siten_col = 1 '支店リストの支店名がある列
   
    siten_row = 1
    sitenmei = Sheets("支店リスト").Cells(siten_row, siten_col)
    Do
        Sheets("全体リスト").Select
        Sheets("全体リスト").Copy
        For zentai_row = zentai_row_bottom To zentai_row_top Step -1
            zentai_sitenmei = Cells(zentai_row, zentai_col_siten)
            If zentai_sitenmei <> sitenmei Then
                Rows(zentai_row).Delete shift:=xlUp
            End If
        Next zentai_row
        fn = sitenmei & ".xlsx"
        ActiveWorkbook.SaveAs Filename:=fn
        ActiveWorkbook.Close
        siten_row = siten_row + 1
        sitenmei = Sheets("支店リスト").Cells(siten_row, siten_col)
    Loop While sitenmei <> ""
End Sub

応用できるように可変部分(行や列)については最初に定数として挙げてあります。
「支店リスト」から支店名を取得します。
「全体リスト」を新しいファイルにシートごとコピーします。
コピー後の「全体リスト」から該当する支店名を探します。
該当しない行については削除して上に詰めます。そのため、下の行から処理を始めるのがポイントです。
不要な行を削除したら、ファイルを保存します。ここでは支店名をファイル名にしています。
次の支店名を取得し、繰り返します。支店名が空になったら終了です。

[ 2010年9月18日 | カテゴリー: Excel | タグ: ]

« | »

コメント

  1. mm より:

    こちらのマクロを参考にさせて頂いています。
    下記の①②にしたい場合は、コードをどうすればいいいのでしょうか。
    自分なりに色々やってはみたのですが、うまくいきません…。

    ①全体リストのレコードの最後の行は毎月同じではないのでマクロ実行の度に変更しない。
    ②「支店リスト」シートのB列にローマ字の支店名を作り、ファイル名をこのローマ字にする。

  2. stabucky より:

    >mmさん
    手元に環境がないので試していませんが、次のようにしてはいかがでしょうか。

    (1)
    「Const zentai_row_bottom = 11」の部分を
    Const zentai_row_bottom = 100
    のように変更します。
    最大行数を超える、適当に大きな数値に書き換えれば、毎回変える必要はないと思います。

    (2)
    「Const siten_col = 1」の下に
    Const siten_roman_col = 2
    を挿入します。
    「fn = sitenmei & “.xlsx”」を
    sitenmei_roman = Sheets(“支店リスト”).Cells(siten_row, siten_roman_col)
    fn = sitenmei_roman & “.xlsx”
    に書き換えます。

    試していただけると幸いです。

  3. mm より:

    stabuckyさん
    回答ありがとうございます。

    sitenmei_roman = Sheets(“支店リスト”).Cells(siten_row, siten_roman_col)のところで
    「インデックスが有効範囲にありません。」で止まってしまいます…。

  4. stabucky より:

    ひょっとするとダブルクォートが半角でないかもしれません。「支店リスト」を挟むダブルクォートを半角にしてみてください。

  5. mm より:

    半角にしていましたが、再度入力してみても同じ結果になります…。

  6. stabucky より:

    そうですか。他に原因を思いつきません。申し訳ありません。

  7. stabucky より:

    mmさん
    「「支店リスト」シートのB列にローマ字の支店名を作り、ファイル名をこのローマ字にする。」の部分ですが、ようやく実機で試すことができました。
    コード全体を貼ります。
    Sub リスト分割()
    Const zentai_row_top = 2 ‘全体リストのレコードの最初の行
    Const zentai_row_bottom = 11 ‘全体リストのレコードの最後の行
    Const zentai_col_siten = 2 ‘全体リストの支店名がある列
    Const siten_col = 1 ‘支店リストの支店名がある列
    Const siten_roman_col = 2 ‘支店リストの支店名(ローマ字)がある列

    siten_row = 1
    sitenmei = Sheets(“支店リスト”).Cells(siten_row, siten_col)
    sitenroman = Sheets(“支店リスト”).Cells(siten_row, siten_roman_col)
    Do
    Sheets(“全体リスト”).Select
    Sheets(“全体リスト”).Copy
    For zentai_row = zentai_row_bottom To zentai_row_top Step -1
    zentai_sitenmei = Cells(zentai_row, zentai_col_siten)
    If zentai_sitenmei <> sitenmei Then
    Rows(zentai_row).Delete shift:=xlUp
    End If
    Next zentai_row
    fn = sitenroman & “.xlsx”
    ActiveWorkbook.SaveAs Filename:=fn
    ActiveWorkbook.Close
    siten_row = siten_row + 1
    sitenmei = Sheets(“支店リスト”).Cells(siten_row, siten_col)
    sitenroman = Sheets(“支店リスト”).Cells(siten_row, siten_roman_col)
    Loop While sitenmei <> “”
    End Sub

  8. mm より:

    stabuckyさん
    出来ました!
    お時間割いて頂きありがとうございました。

  9. stabucky より:

    mmさん
    できましたか!とても嬉しいです。

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です

送信してください。


タグ

カテゴリー

最近の投稿

最近のコメント

固定ページ

アーカイブ

stabucky

写真

メタ情報