外出自粛中でも楽しく過ごす!QAまとめ>>

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

やりたいことは、
(1)「エリア1」にある名称ごとに同じBookの別シートに振り分け
(2)各シートで「累計売上」順(降順)に並べ替え
の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  
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行ぐらいデータが続きます。

このQ&Aに関連する最新のQ&A

A 回答 (3件)

見た感じ、そんなに鈍重なコードではないように見えますが・・


貼り付け位置がAJ列と言うことですから、
「このコードのほかに何か処理」をさせていませんか?
その「他の処理」に関して動きが悪いのであれば何とも言えません。

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


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

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

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

*「AJ:ATの範囲を消去する」場合
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

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

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



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

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

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

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

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

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

お礼日時:2013/06/11 00:02

No.1です!


たびたびごめんなさい。

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

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
    • good
    • 0
この回答へのお礼

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

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

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

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

お礼日時:2013/06/11 00:14

こんばんは!


気になる点が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
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!


人気Q&Aランキング