| |
こんなかな？
ActiveSheetの該当条件データ行を削除しますので
必ずBuckUpを取ってから試して下さい
Option Explicit
Public Sub RowsDelete()
'Listの列数
Const clngColumns As Long = 14
'日付の有る列位置（Listの左端からの列Offset値）
Const clngDate As Long = 0
'不良率の有る列位置（Listの左端からの列Offset値）
Const clngReject As Long = 13
Dim i As Long
Dim rngList As Range
Dim lngResult() As Long
Dim lngRows As Long
Dim lngCount As Long
Dim vntDate As Variant
Dim strProm As String
'Listの左上隅を基準とする（列見出しがある物とします）
Set rngList = ActiveSheet.Cells(1, "A")
With rngList
lngRows = .Offset(65536 - .Row).End(xlUp).Row - .Row
If lngRows <= 1 Then
strProm = "データが有りません"
GoTo Wayout
End If
'Listを日付降順の不良率降順に整列
.Offset(1).Resize(lngRows, clngColumns).Sort _
Key1:=.Offset(1, clngDate), Order1:=xlDescending, _
Key2:=.Offset(1, clngReject), Order2:=xlDescending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'日付を配列に取得
vntDate = .Offset(1, clngDate).Resize(lngRows).Value
End With
'整列Key用配列を確保
ReDim lngResult(1 To lngRows, 1 To 1)
lngCount = 1
For i = 2 To lngRows
'日付が違ったら、整列Key用配列に1を代入
If vntDate(i - 1, 1) = vntDate(i, 1) Then
lngResult(i, 1) = 1
Else
lngCount = lngCount + 1
End If
Next i
Application.ScreenUpdating = False
With rngList
.EntireColumn.Insert
.Offset(1, -1).Resize(lngRows).Value = lngResult
'Listを整列Key昇順に整列
.Offset(1, -1).Resize(lngRows, clngColumns + 1).Sort _
Key1:=.Offset(1, -1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom, SortMethod:=xlStroke
'必要外の行削除
.Offset(lngCount + 1).Resize(lngRows - lngCount).EntireRow.Delete
.Offset(1, -1).EntireColumn.Delete
End With
Application.ScreenUpdating = True
strProm = "処理が完了しました"
Wayout:
Set rngList = Nothing
Beep
MsgBox strProm
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
