| |
コードにするとこんなかな？
幾分速く成ると思います
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
'削除する行が在るなら
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
End Sub
|
|
Hirofumi
- 09/6/10(水) 9:47 -
