| |
データの量が多い場合は1行づつ削除では遅いので
先に、隣の列に削除Flagを立てて、それをKeyにソートし
下の行に削除する行を集めて一気に削除します
Option Explicit
Public Sub Sample2()
'◆データ列数（A列のみ）
Const clngColumns As Long = 1
'◆Keyと成る列を指定(基準セル位置からの列Offsetで指定：基準がA列なので0)
Const clngKeys As Long = 0
Dim i As Long
Dim lngRows As Long
Dim rngList As Range
Dim vntData As Variant
Dim lngDelete() As Long
Dim lngCount As Long
Dim strProm As String
'◆Listの先頭セル位置を基準とする（A列のデータ先頭のセル位置）
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
'行数の取得
lngRows = .Offset(Rows.Count - .Row, clngKeys).End(xlUp).Row - .Row + 1
If lngRows <= 1 And .Value = "" Then
strProm = "データが有りません"
GoTo Wayout
End If
'A列データを配列に取得
vntData = .Offset(, clngKeys).Resize(lngRows + 1).Value
'削除Flag用の配列を確保
ReDim lngDelete(1 To lngRows, 1 To 1)
End With
'数値以外なら削除Flagに1を立てる
For i = 1 To lngRows
'数値以外なら
If (Not IsNumeric(vntData(i, 1))) Or (IsEmpty(vntData(i, 1))) Then
'Flagに1を立てる
lngDelete(i, 1) = 1
'削除行数をカウント
lngCount = lngCount + 1
End If
Next i
'画面更新を停止
Application.ScreenUpdating = False
With rngList
'削除行が有るなら
If lngCount > 0 Then
'FlagをL列に出力
.Offset(, clngColumns).Resize(lngRows) = lngDelete
'空白行を最終行に集める為、L列をKeyとして整列
.Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'削除行を削除
.Offset(lngRows - lngCount).Resize(lngCount).EntireRow.Select
.Offset(lngRows - lngCount).Resize(lngCount).EntireRow.Delete
'削除Flag列を削除
strProm = lngCount & "件の削除処理が完了しました"
Else
strProm = "削除行は有りません"
End If
End With
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 08/10/27(月) 19:17 -
