VBAのスピードについてご教示ください

質問

下記マクロは、シートAに氏名、郵便番号、住所・・・、と横に住所録を整理していて、列11番目に「対象」と入力されている行を順番にコピーして、シート「送付先一覧」に貼り付けるマクロをコピーしてエクセル2010で使用させていただいてるのですが、職場のエクセル2007では極端にスピードが遅くなります。
エクセル2007では、2010のように早くはならないのでしょうか？
2007を使用してるパソコンが、少し古いからでしょうか？
素人でよくわかりません。
遅くなる理由、また早くする方法があればご教示ください。

Sub 対象抽出()

Dim i, LastRow As Long
LastRow = Cells(Rows.count, 11).End(xlUp).Row
For i = 1 To LastRow
If Cells(i, 11) = "対象" Then
Rows(i).Copy Sheets("送付先一覧").Cells(Rows.count, 1).End(xlUp).Offset(1, 0)
End If
Next i

End Sub

回答No.5

cj_mover · ベストアンサー

たびたびすみません。＃３、４、ｃｊです。
訂正が一点、補足が一点、です。

＃４、Sub Re8097433c()の
２つめの' 追加（５行）が編集ミスで誤った記述になっていました。
正しくは、

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub Re8097433c()

　　Dim i, LastRow As Long, PrintRow As Long

　　With Application ' 追加（５行）
　　　　.ScreenUpdating = False ' 描画更新抑止
　　　　.EnableEvents = False ' イベント発行停止
　　　　.Calculation = xlCalculationManual ' 再計算手動化
　　End With

　　LastRow = Cells(Rows.Count, 11).End(xlUp).Row ' 追加
　　With Sheets("送付先一覧") ' 追加
　　　　PrintRow = .Cells(Rows.Count, 1).End(xlUp).Row ' 追加
　　　　For i = 1 To LastRow
　　　　　　If Cells(i, 11) = "対象" Then
　　　　　　　　PrintRow = PrintRow + 1 ' 追加
　　　　　　　　Rows(i).Copy .Cells(PrintRow, 1) ' 変更
　　　　　　End If
　　　　Next i
　　End With ' 追加

　　With Application ' 追加（５行）
　　　　.ScreenUpdating = True ' 描画更新再開
　　　　.EnableEvents = True ' イベント発行再開
　　　　.Calculation = xlCalculationAutomatic ' 再計算自動化
　　End With

End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

でした、以上訂正お願いします。

また、
＃３、Sub Re8097433s()の

　　With ActiveSheet ' （２／２択）

についてですが、
標準モジュールの記述として書いています。
ひょっとして、Sheetモジュールで使ってた場合は

　　With Me ' （２／２択）

と書き換える必要があります。
こちらは、オプショナルな話ですけれど。

失礼しました。

お礼

何度もありがとうございました。
また、お礼が遅くなって申し訳ありませんでした。

皆さんからご教示いただいたものを参考にして、作成することができました。
本当にありがとうございました。

回答No.4

cj_mover

＃３、ｃｊです。

ご提示のコードの骨格は変えずに、
無駄を減らして、遅くなる原因への手当てを幾つか追加して
いくらか速くして、また、2007と2010での速度差を減らす方向で
考えてみました。
オブジェクトへのアクセスを簡単にすることがテーマですが、
元コードの形を留めるように意識して書いています。

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

Sub Re8097433c()

　　Dim i, LastRow As Long, PrintRow As Long

　　With Application ' 追加（５行）
　　　　.ScreenUpdating = False ' 描画更新抑止
　　　　.EnableEvents = False ' イベント発行停止
　　　　.Calculation = xlCalculationManual ' 再計算手動化
　　End With

　　LastRow = Cells(Rows.Count, 11).End(xlUp).Row ' 追加
　　With Sheets("送付先一覧") ' 追加
　　　　PrintRow = .Cells(Rows.Count, 1).End(xlUp).Row ' 追加
　　　　For i = 1 To LastRow
　　　　　　If Cells(i, 11) = "対象" Then
　　　　　　　　PrintRow = PrintRow + 1 ' 追加
　　　　　　　　Rows(i).Copy .Cells(PrintRow, 1) ' 変更
　　　　　　End If
　　　　Next i
　　End With ' 追加

　　With Application ' 追加（５行）
　　　　.ScreenUpdating = False ' 描画更新再開
　　　　.EnableEvents = False ' イベント発行再開
　　　　.Calculation = xlCalculationManual ' 再計算自動化
　　End With

End Sub

' ' ＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝＝

＃３の補足ですが

　　　　　　　　.Rows(rngFoundTop.Row & ":" & nFoundBtmRow).Copy Sheets("送付先一覧").Cells(1) ' ●

これ↑だと、常にSheets("送付先一覧")の先頭から書き出すようになっています。
そうではなくてSheets("送付先一覧")のＡ列最下行に続けて出力するということでしたら、

　　　　　　　　.Rows(rngFoundTop.Row & ":" & nFoundBtmRow).Copy Sheets("送付先一覧").Cells(Rows.count, 1).End(xlUp).Offset(1, 0) ' ●

と書き換える必要があります。

///

＃３では雑に書いてしまいましたが、コピーする必要、についてです。
例えば、
書式をコピーする必要があるか、
例えば、
入力規則が設定されているなら、それもコピーする必要があるか、
例えば、
ボタンなどのコントロールや各種図形が配置されているなら、それもコピーする必要があるか
例えば、
コピー元に数式を設定してある場合、数式のまま貼り付けするか、値のみ貼り付けするか、
とか、、、
こういうこと、ひとつひとつ不要なものをはずしていくことで、
遅さの解消の見込みは立ってくると思いますので。

以上です。

回答No.3

cj_mover

こんにちは。お邪魔します。

Excel一般機能を使うのでしたら、
　並べ替えて
　"対象"範囲を一塊りでコピペ
　並べ替えを元に戻す
という手順が速そうです。
一応、26列*20000行 のダミーサンプルを基準に作成、
XL2010で動作確認しています。
当方、XL2007では試していませんが、理論上同等の効果は出せる筈です。
遅くなる理由はよくわかりませんが、コピー対象となるシェイプが複数あるとか？
何れにしてもコピーしなくていいものはコピーしないように検討してもいいかも。

Excel一般機能フル活用版です。
マクロの記録で得たコードの組み合わせ・アレンジです。
VBAは知らなくてもExcelを知ってる人なら手作業でできるような
基本テクニックしか使っていません。
一応、速くする、方向でお応えしていますが、
こちらでニーズを読み違えているようでしたらご指摘ください。

Sub Re8097433s() ' ' ●要指定：４カ所
　　Dim rngSearch As Range ' ' UsedRange 内の検索対象列
　　Dim rngSearchBtm As Range ' ' UsedRange の最下セル
　　Dim rngReSortKey As Range ' ' 並べ替え復旧用のキー列
　　Dim rngFoundTop As Range ' 検索最上セル
　　Dim tnRows As Long ' ' UsedRange の行数
　　Dim nReSortKeyCol As Long ' ' 並べ替え復旧用のキー列位置
　　Dim nFoundBtmRow As Long ' 検索最下セルの行位置

　　Application.ScreenUpdating = False ' お好みで
'　　With Sheets("Sheet1") ' （１／２択）●元データシートをシート名で指定！！
　　With ActiveSheet ' （２／２択）
　　　　With .UsedRange
　　　　　　tnRows = .Rows.Count
　　　　　　Set rngSearch = .Columns(11) ' ●
　　　　　　Set rngSearchBtm = rngSearch.Cells(tnRows)
　　　　　　nReSortKeyCol = .Columns.Count + 1
　　　　　　Set rngReSortKey = .Columns(nReSortKeyCol)
　　　　　　With rngReSortKey
　　　　　　　　.Value = "=ROW()"
　　　　　　　　.Value = .Value
　　　　　　End With
　　　　　　.Resize(, nReSortKeyCol).Sort Key1:=rngSearch, Order1:=xlDescending, Header:=xlNo
　　　　　　Set rngFoundTop = rngSearch.Find(What:="対象", After:=rngSearchBtm, LookAt:=xlWhole, SearchOrder:=xlByRows) ' ●
　　　　　　If Not rngFoundTop Is Nothing Then
　　　　　　　　nFoundBtmRow = .Range(rngFoundTop, rngSearchBtm).ColumnDifferences(rngFoundTop).Row - 1
　　　　　　　　.Rows(rngFoundTop.Row & ":" & nFoundBtmRow).Copy Sheets("送付先一覧").Cells(1) ' ●
　　　　　　End If
　　　　　　.Resize(, nReSortKeyCol).Sort Key1:=rngReSortKey, Order1:=xlAscending, Header:=xlNo
　　　　　　rngReSortKey.ClearContents
　　　　End With
　　　　nFoundBtmRow = .UsedRange.Row
　　End With
　　Set rngSearch = Nothing:　　Set rngSearchBtm = Nothing:　　Set rngReSortKey = Nothing:　　Set rngFoundTop = Nothing

End Sub

回答No.2

mt2008

処理を早くしたいなら、画面描画を抑止するのが効果ありです。

For i = 1 To LastRow　……の前に↓を、
Application.ScreenUpdating = False

Next i　……の後に↓を
Application.ScreenUpdating = True

入れてみてください。

お礼

ご教示ありがとうございました。
また、お礼が遅くなり申し訳ありません。

ご教示頂いたもので、かなり早くなりました。
今後、他で利用させていただきます。

皆さんからのご教示を参考に、かなり早いものを作成することができました。
ありがとうございます。

回答No.1

tom04

こんばんは！
データ量にもよりますが、For～Nextでループするより、オートフィルタを使った方が早いと思います。

おそらく、「送付先一覧」Sheetの2行目以降に表示するコードだと思いますので、
元データがあるSheetのシートモジュールにしてマクロを実行してみてください。

Sub Sample1()
Dim i As Long
With ActiveSheet
.Rows(1).Insert
.Cells(1, 11) = "ダミー"
.Cells(1, 11).AutoFilter field:=11, Criteria1:="対象"
i = .Cells(Rows.Count, 11).End(xlUp).Row
.Rows(2 & ":" & i).Copy Worksheets("送付先一覧").Cells(2, 1)
.AutoFilterMode = False
.Rows(1).Delete
End With
End Sub

少しは早くなると思います。m(_ _)m

お礼

お礼が遅くなって申し訳ありません。
また、早速のご教示ありがとうございました。
ご教示いただいたものを参考に、作成るすことができました。
やはりオートフィルタを使った方法が一番早い感じですね。
ありがとうございました。