質問: true msgbox "各地区シートにデータを振分けました。" end sub 【元データの形式は以下のような形になってます。】 a b c d e f g h i j 4 コード s番号 s名称 s名 月間個数 月間売上 累計個数 累計売上 エリア1 エリア2 5 4237 4025 aaa あああ 3 150 7 350 京後 後a 6 6769 4025 aaa いいい 2 100 5 250 京中 中b 7 3453 4028 bbb ううう 5 50 5 50 京後 後c 8 4252 4029 ccc えええ 1 110 9 990 京前 前a 9 3564 4027 ddd おおお 0 0 8 80 京前 前a 10 8035 4022 eee かかか 1 30 2 60 京中 中b 11 9225 4026 eee ききき 2 40 3 60 京後 後a 以下5000行ぐらいデータが続きます。
回答: こんばんは! 気になる点が2か所あります。 (1)各シートに振り分けるたびにオートフィルタを解除・設定と繰り返していますが、それをやめてみてはどうでしょうか? (2)データがあるなしにかかわらずf4~p65500の範囲をコピー&ペーストしていますが、データの最終行を取得してその範囲だけをコピー&ペーストしてはダメですか? 一応上記のコトを考慮して少し手を加えさせていただきました。 sub macro2() dim endrow as long application.screenupdating = false with worksheets("元データシート") .range("a5").autofilter field:=9, criteria1:="京前" endrow = .cells(rows.count, "f").end(xlup).row worksheets("前 品別").cells.clearcontents .range("f4:p" & endrow).copy worksheets("前 品別").range("aj5") .range("a5").autofilter field:=9, criteria1:="京中" endrow = .cells(rows.count, "f").end(xlup).row worksheets("中 品別").cells.clearcontents .range("f4:p" & endrow).copy worksheets("中 品別").range("aj5") .range("a5").autofilter field:=9, criteria1:="京後" worksheets("後 品別").cells.clearcontents endrow = .cells(rows.count, "f").end(xlup).row .range("f4:p" & endrow).copy worksheets("後 品別").range("aj5") .autofiltermode = false end with application.screenupdating = true msgbox "各地区シートにデータを振分けました。" end sub ※ 各シートにコピー&ペーストする前に、各シートのデータをすべてクリアしていますので、 消してはいけないデータがある場合は別途考える必要があります。 少しは早くなりますかね?m(_ _)m