Excel VBAについてご教ください

質問

いつも、こちらのサイトをみながら、VBAを勉強させていただいているのですが、
今回、自分のやりたいことが見当たりませんでしたので、ご教示いただければと思います。

やりたいことは、
(1)「エリア１」にある名称ごとに同じBookの別シートに振り分け
(2)各シートで「累計売上」順（降順）に並べ替え
の２つの作業を同時に行いたいのです。

また、
(1)には、あらかじめ決まったシートが用意されているので、
そのシートの決められた範囲にデータを移したいのと、
データを貼り付ける前に、前に残っている前回のデータを削除してから、同場所に貼り付けを行いたいです。
ちなみに、エリアが3つあるので、シートも3枚あります。

自分でも、いろいろとやってみて、
下記のようなコードを書いたのですが、あまりにも重くて、動きがわるかったため、
シンプルかつ、軽やかに動くコードの書き方をお教えいただければと思います。
よろしくお願いいたします。

Sub Macro2()
Application.ScreenUpdating = False
With Worksheets("元データシート")
.Range("A5").AutoFilter _
Field:=9, _
Criteria1:="京前", Operator:=xlAnd
.Range("F4：P65500").Copy _
Worksheets("前 品別").Range("AJ5")
.AutoFilterMode = False

.Range("A5").AutoFilter _
Field:=9, _
Criteria1:="京中", Operator:=xlAnd
.Range("F4：P65500").Copy _
Worksheets("中 品別").Range("AJ5")
.AutoFilterMode = False

.Range("A5").AutoFilter _
Field:=9, _
Criteria1:="京後", Operator:=xlAnd
.Range("F4：P65500").Copy _
Worksheets("後 品別").Range("AJ5")
.AutoFilterMode = False

End With
Application.ScreenUpdating = True

MsgBox "各地区シートにデータを振分けました。"

End Sub

【元データの形式は以下のような形になってます。】
　　　　A　　　　B　　　　C　　　　D　　　　　E　　　　　　　F　　　　　　G　　　　　　H　　　　　　I　　　　　J　　
４　　コード　S番号　S名称　　S名　　月間個数　月間売上　累計個数　累計売上　エリア1　　エリア2
５　　4237　　4025　　AAA　 あああ　　　3　　　　　　150　　　　　7　　　　　　350　　　　京後　　　　後A　　　
６　　6769　　4025　　AAA　 いいい　　　2　　　　　　100　　　　　5　　　　　　250　　　　京中　　　　中B
７　　3453　　4028　　BBB　 ううう　　　　5　　　　　　　50　　　　　5　　　　　　　50　　　　京後　　　　後C
８　　4252　　4029　　CCC　 えええ　　　1　　　　　　110　　　　　9　　　　　　990　　　　京前　　　　前A
９　　3564　　4027　　DDD　 おおお　　　0　　　　　　　0　　　　　　8　　　　　　80　　　　京前　　　　前A
１０　8035　　4022　　EEE　 かかか　　　1　　　　　　　30　　　　　2　　　　　　60　　　　　京中　　　　中B
１１　9225　　4026　　EEE　 ききき　　　　2　　　　　　 40　　　　　3　　　　　　　60　　　　京後　　　　後A
以下5000行ぐらいデータが続きます。

回答No.2

tsubuyuki · ベストアンサー

見た感じ、そんなに鈍重なコードではないように見えますが・・
貼り付け位置がＡＪ列と言うことですから、
「このコードのほかに何か処理」をさせていませんか？
その「他の処理」に関して動きが悪いのであれば何とも言えません。

ですので、とりあえず質問文からわかる範囲で。

> 前に残っている前回のデータを削除して

コレも「行全体を削除」なのか、貼り付けるべき「ＡＪ：ＡＴの範囲を消去」するのか
質問文からは判断できませんので、両方の可能性を見越して。

＊「行全体を削除する」の場合
Sub 指定行削除()
　　　　For i = 2 To Sheets.Count
　　　　　　　　Sheets(i).Rows(5 & ":" & Cells(Rows.Count, 36).End(xlUp).Row).Delete
　　　　Next
End Sub

＊「ＡＪ：ＡＴの範囲を消去する」場合
Sub 指定範囲消去()
　　　　For i = 2 To Sheets.Count
　　　　　　　　Sheets(i).Range("AJ5:AT" & Cells(Rows.Count, 36).End(xlUp).Row).ClearContents
　　　　Next
End Sub

どちらも元データシートが先頭に在ると仮定し、その他の全てのシートに処理をかけています。
このどちらかをコードの始めに持っていくと「今あるデータを削除（消去）して」先に進みます。

ちなみにエラーは考慮しておりません。

続いて
> 各シートで「累計売上」順（降順）に並べ替え

「マクロの記録」機能はご存知でしょうか。
単純にこの「降順に並べ替え」の処理を記録してやると
　　　　Selection.Sort Key1:=Range("AL6"), Order1:=xlDescending, Header:=xlGuess _
　　　　, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
　　　　SortMethod:=xlPinYin
こんな感じで記録されると思いますので、コレをちょっと書き直せば出来ますね。
ソレを先ほどの「削除」同様、対象の全シートで走るように手を加えれば良いです。

Sub 降順で並べ替え()
　　　　For i = 2 To Sheets.Count
　　　　　　　　Sheets(i).Range("AJ5").Sort Key1:=Sheets(i).Range("AL6"), _
　　　　　　　　　　　　　　　　　　　　　　Order1:=xlDescending, _
　　　　　　　　　　　　　　　　　　　　　　Header:=xlGuess, _
　　　　　　　　　　　　　　　　　　　　　　OrderCustom:=1, _
　　　　　　　　　　　　　　　　　　　　　　MatchCase:=False, _
　　　　　　　　　　　　　　　　　　　　　　Orientation:=xlTopToBottom, _
　　　　　　　　　　　　　　　　　　　　　　SortMethod:=xlPinYin
　　　　Next
End Sub

同様に、元データシートが先頭に在ると仮定し、その他の全てのシートに処理をかけています。
これはコードの最後に付け加えてやれば良いですね。

これもエラーの考慮はしていません。

ちなみに、７０００件でコチラで走らせてみましたが
消去～転記～並べ替えの作業を続けても１秒かからずくらいですね。
「速度」だけ考えると立派な数字だと思いますよ。

書き方は色々有るのかなぁ、とも思いますが、
質問文中の「コードの一部」だけでは判断できません。
悪しからずご了承下さいませ。

お礼

ありがとうございます。
言葉足らずなところがあり、ご迷惑をおかけいたしました。

>「このコードのほかに何か処理」をさせていませんか？
貼り付け位置以外には、関数が入っております。
しかしながら、貼り付け位置に手動で（オートフィルターなどを駆使し）貼り付けていたときは、ファイルサイズが3Ｍほどであったものが、なぜかマクロ組み入れ後に22Ｍとなっており、困っていたものです。

> 前に残っている前回のデータを削除して
「ＡＪ：ＡＴの範囲を消去する」という解釈であっております。

パーツごとに書いてくださり、とても分かりやすく勉強になります。
ありがとうございます。

回答No.3

tom04

No.１です！
たびたびごめんなさい。

（２）の降順に並び替え！を忘れていました。
もう一度コードを最初から載せてみます。

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")
Worksheets("前 品別").Range("AJ5").CurrentRegion.Sort key1:=Worksheets("前 品別").Range("AL5"), _
order1:=xlDescending, Header:=xlYes

.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")
Worksheets("中 品別").Range("AJ5").CurrentRegion.Sort key1:=Worksheets("中 品別").Range("AL5"), _
order1:=xlDescending, Header:=xlYes

.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")
Worksheets("後 品別").Range("AJ5").CurrentRegion.Sort key1:=Worksheets("後 品別").Range("AL5"), _
order1:=xlDescending, Header:=xlYes
.AutoFilterMode = False
End With
Application.ScreenUpdating = True
MsgBox "各地区シートにデータを振分けました。"
End Sub

※　じっくり考えればもっと簡単になると思います。
取り急ぎ投稿します。m(_ _)m

お礼

回答いただきありがとうございます。
>（１）各シートに振り分けるたびにオートフィルタを解除・設定と繰り返していますが、それをやめてみてはどうでしょうか？
その通りだと思いますｆ(――;)

>（２）データがあるなしにかかわらずF4～P65500の範囲をコピー＆ペーストしていますが、データの最終行を取得してその範囲だけをコピー＆ペーストしてはダメですか？
全然かまわないです。
ただ、指定範囲外には関数が入っておりますので、消したくはないです。

言葉足らずなところがあり、また、
考え方が、まだまだ甘かったことを痛感いたしております。

これからも、ご教授いただければと思います。

回答No.1

tom04

こんばんは！
気になる点が２か所あります。
（１）各シートに振り分けるたびにオートフィルタを解除・設定と繰り返していますが、それをやめてみてはどうでしょうか？
（２）データがあるなしにかかわらず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