| |
▼YOUSUKE さん：
>Hirofumi さんの言うとおりに、教えていただいた、コマンドでものすごく早くなりました。数倍、体感的には10倍くらい早い感じがします。ありがとうございます。
>このコマンドなんですが、整列してまとめて、消去するだけでここまで早くなるも物なのでしょうか？ 配列など巧みに使用されていますが、この辺も速度アップに関係しているのでしょうか？
Excelの行列の削除は、前のレスで書いた様に纏めて（特に後ろにデータが無い様にして）
削除する方がが速く成ると思います
また、基本的にセルに対する読み書きは、1つづつ行うと変数に対する其れと違い
非常に時間が掛かります
因って、在るセル範囲に対する読み出しを行う場合、一括して配列変数に読み込んで
この配列変数の値を使います
また、セル範囲に書き出す場合、配列変数を確保して此れに結果を書き込んだ上で
配列変数をセル範囲に出力した方が一般的に速く成ると思います
しかし、配列変数の使い方自体は難しい事は無いのですが？
配列変数はリソースを食いますので、無暗に巨大な配列変数を使うと帰ってパホーマンスに
影響を与えると思います
ですので、配列変数を使う場合、配列変数のサイズを考慮して使用するのが効果的だと思います
尚、今回は使用していませんが
'画面更新を停止
Application.ScreenUpdating = False
'画面更新を再開
Application.ScreenUpdating = True
を併用しても効果が有ると思います
Option Explicit
Public Sub Sample()
Dim i As Long
Dim lngRows As Long 'データ行数
Dim lngCount As Long '削除数
Dim vntSheets As Variant '対象シート名の一覧
Dim vntTop As Variant '対象シートのデータ先頭行
Dim vntColumns As Variant '対象シートの最終データ列位置
Dim lngDelete() As Long '削除行のFlag
Dim vntKeys1 As Variant
Dim vntKeys2 As Variant
vntSheets = Array("D1", "D2", "D3", "D4", "D5", "D6")
vntTop = Array(3, 3, 3, 3, 3, 1)
vntColumns = Array(130, 130, 130, 130, 130, 130)
lngRows = 800
'D1シートに就いて
With Worksheets(vntSheets(0))
'130列のデータを配列に取得
vntKeys1 = .Range(.Cells(vntTop(0), 130), _
.Cells(vntTop(0) + lngRows - 1, 130)).Value
'1列のデータを配列に取得
vntKeys2 = .Range(.Cells(vntTop(0), 1), _
.Cells(vntTop(0) + lngRows - 1, 1)).Value
End With
'削除Flag用の配列を確保
ReDim lngDelete(1 To lngRows, 1 To 1)
'削除Flagを作成
For i = 1 To lngRows
If vntKeys1(i, 1) = "" Or vntKeys2(i, 1) < 50 Then
lngDelete(i, 1) = 1
lngCount = lngCount + 1
End If
Next i
'画面更新を停止
Application.ScreenUpdating = False '★追加
'削除する行が在るなら
If lngCount > 0 Then
'シート一覧に基いて
For i = 0 To UBound(vntSheets)
With Worksheets(vntSheets(i))
'最終列の後ろに削除Flagを出力
.Cells(vntTop(i), vntColumns(i) + 1).Resize(lngRows).Value = lngDelete
'削除FlagをKeyとしてListを整列
.Cells(vntTop(i), 1).Resize(lngRows, vntColumns(i) + 1).Sort _
key1:=.Cells(vntTop(i), vntColumns(i) + 1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'削除Flagが1の行を削除
.Cells(vntTop(i) + lngRows - lngCount, 1).Resize(lngCount).EntireRow.Delete
'削除Flagを削除
.Cells(vntTop(i), vntColumns(i) + 1).EntireColumn.Delete
End With
Next i
End If
'画面更新を再開
Application.ScreenUpdating = True '★追加
MsgBox "処理が完了しました", vbInformation '★追加
End Sub
|
|
Hirofumi
- 09/6/11(木) 8:50 -
