| |
この方が速いかも？
Option Explicit
Public Sub Sample2()
Dim i As Long
Dim lngCount As Long
Dim lngRows As Long
Dim lngColumns As Long
Dim rngList As Range
Dim rngResult As Range
Dim vntData As Variant
Dim lngDelete() As Long
Dim strProm As String
'結果を出力する位置すぉ指定
Set rngResult = Worksheets("Sheet2").Cells(1, 1)
'画面更新を停止
Application.ScreenUpdating = False
With Worksheets("Sheet1").UsedRange
'◆Listの先頭セル位置を基準とする
Set rngList = .Cells(1, 1)
'行列数の取得
lngRows = .Rows.Count
lngColumns = .Columns.Count
If .Count = 1 Then
strProm = "データが有りません"
GoTo Wayout
End If
'データ全てをSheet2にCopy
.Copy Destination:=rngResult
'先頭列の値を配列に取得
vntData = rngList.Resize(lngRows + 1).Value
'削除Flag用の配列を確保
ReDim lngDelete(1 To lngRows, 1 To 1)
End With
With rngResult
'先頭列の値が文字列なら削除Flagに1を立てる
For i = 1 To lngRows
'先頭列の値が空白で若しくは、数値で無いなら
If vntData(i, 1) = "" Or (Not IsNumeric(vntData(i, 1))) Then
'Flagに1を立てる
lngDelete(i, 1) = 1
'削除行数をカウント
lngCount = lngCount + 1
End If
Next i
End With
With rngResult
If lngCount > 0 Then
'FlagをL列に出力
.Offset(, lngColumns).Resize(lngRows) = lngDelete
'削除行を最終行に集める為、L列をKeyとして整列
.Resize(lngRows, lngColumns + 1).Sort _
Key1:=.Offset(, lngColumns), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'行を削除
.Offset(lngRows - lngCount).Resize(lngCount).EntireRow.Delete
'Keyを削除
.Offset(, lngColumns).EntireColumn.Delete
End If
End With
strProm = "処理が完了しました"
Wayout:
'画面更新を再開
Application.ScreenUpdating = True
Set rngList = Nothing
Set rngResult = Nothing
MsgBox strProm, vbInformation
End Sub
|
|
Hirofumi
- 08/10/5(日) 18:41 -
