| 
    
     |  | こんな感じになりませんか?参考にしてください。 
 Sub test()
 Dim dic   As Object
 Dim lastRow As Long
 Dim myRange As Range
 Dim myMax  As Double, myMin As Double
 Dim target As Double
 Dim v    As Double
 Dim k    As Long
 
 Set dic = CreateObject("Scripting.Dictionary")
 lastRow = Cells(Rows.Count, 1).End(xlUp).Row
 
 '基準値の作成
 Set myRange = Range(Cells(2, 5), Cells(Rows.Count, 5).End(xlUp))
 myMax = Application.WorksheetFunction.Max(myRange)
 myMin = Application.WorksheetFunction.Min(myRange)
 target = myMin + (myMax - myMin) * 2 / 3
 
 'x座標番号が1 かつ z座標が基準値を超えていたら、
 '対応するy座標番号 を Dictionaryに保存
 For k = 2 To lastRow
 v = Cells(k, 5).Value
 If Cells(k, 1).Value = 1 And v > target Then
 dic(Cells(k, 2).Value) = Empty
 End If
 Next
 
 'そのy座標番号のデータをすべて削除する
 For k = lastRow To 2 Step -1
 If dic.Exists(Cells(k, 2).Value) Then
 '' Rows(k).Delete
 Cells(k, 6).Value = 1
 End If
 Next
 End Sub
 
 
 |  |