| |
試しにこんな事して見ると効果の具合が解ると思います
コードの始まりと終わりで時刻を取って、その差をMsgBoxで表示します
削除対象のデータを同じ物を用意して下さい
先ず、Upされたコードで
Public Sub Test()
Dim j As Long
Dim sngTime1 As Single
Dim sngTime2 As Single
sngTime2 = Timer
For j = 800 To 1 Step -1
If Worksheets("D1").Cells(j + 2, 130) = "" Or Worksheets("D1").Cells(j + 2, 1) < 50 Then
Worksheets("D1").Rows(j + 2).Delete SHIFT:=xlUp
Worksheets("D2").Rows(j + 2).Delete SHIFT:=xlUp
Worksheets("D3").Rows(j + 2).Delete SHIFT:=xlUp
Worksheets("D4").Rows(j + 2).Delete SHIFT:=xlUp
Worksheets("D5").Rows(j + 2).Delete SHIFT:=xlUp
Worksheets("D6").Rows(j).Delete SHIFT:=xlUp
End If
Next j
sngTime1 = Timer
MsgBox "処理が完了しました" & vbLf & (sngTime1 - sngTime2), vbInformation
End Sub
次に、回答したコードで
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
Dim sngTime1 As Single
Dim sngTime2 As Single
sngTime2 = Timer
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 '★追加
sngTime1 = Timer
MsgBox "処理が完了しました" & vbLf & (sngTime1 - sngTime2), vbInformation
End Sub
次に、回答したコードから、Key1、Key2、削除FlagのlngDeleteを廃し、
直接セルに対する読み書きに変更した物
Public Sub Sample_3()
' 配列変数を使用しない
Dim i As Long
Dim j As Long
Dim lngRows As Long 'データ行数
Dim lngCount As Long '削除数
Dim vntSheets As Variant '対象シート名の一覧
Dim vntTop As Variant '対象シートのデータ先頭行
Dim vntColumns As Variant '対象シートの最終データ列位置
Dim sngTime1 As Single
Dim sngTime2 As Single
sngTime2 = Timer
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
'削除Flagを作成
For i = 1 To lngRows
'条件に合わない物に印を付ける
If Not (Worksheets(vntSheets(0)).Cells(vntTop(0) + i - 1, 130).Value = "" _
Or Worksheets(vntSheets(0)).Cells(vntTop(0) + i - 1, 1).Value < 50) Then
For j = 0 To UBound(vntSheets)
Worksheets(vntSheets(j)).Cells(vntTop(j) + i - 1, vntColumns(j) + 1).Value = "*"
Next j
Else
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を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 '★追加
sngTime1 = Timer
MsgBox "処理が完了しました" & vbLf & (sngTime1 - sngTime2), vbInformation
End Sub
私の機器では、
元々のコードで：約 7.44秒
回答のコードで：約 0.32秒
廃したコードで：約 0.42秒
800行程度ですので、余り差は無い様ですが配列変数を使った方が効果は有ります
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
