エクセル データの該当条件と表の削除

質問

エクセル2010を使っています。

ちょっと一人では難しいものが出てきましたので教えていただけませんでしょうか。

画像の様に、A1～EO８が一つになった表があります。

その表は画像の様に、８行ごとに新しい表として、下行にずっと続いています。

F列には、数値が入っていて、条件に適合すれば、表ごと削除し上に詰めて行きたいと思います。

その条件とは、
一つの表のF列に、○○以下の数値が６個以上あったらその表を削除し、上に詰める、というものです。

例として、数値が0.8以下だとすれば、A1～EO８の表のF列には、0.8以下の数値が６個ありますので１行～８行は削除されます。

これを、ボタンクリックで行います。

またデータが存在する限り繰り返したいと思います。

ちなみに、別バージョンとしてG列に数値があるパターンもあり、該当個数の条件も６個、５個と任意で書き換えが出来る形が理想形です。

詳しい方、よろしくお願い致します。

回答No.1

tom04 · ベストアンサー

こんばんは！

＞書き換えが出来る形が理想形です。
いちいち書き換えずにインプットボックスに3つの条件を入力する方法にしてみました。
「表」ではなく行すべてを削除しています。

Sub Sample1()
Dim i As Long, k As Long, cnt As Long, myRng As Range
Dim str As String, myCnt As Long, myVal
str = Application.InputBox("対象列番号をアルファベットで入力")
myVal = Application.InputBox("数値を入力")
myCnt = Application.InputBox("検索個数を入力")
On Error Resume Next '←念のため★
For k = 1 To Cells(Rows.Count, str).End(xlUp).Row Step 8
If WorksheetFunction.CountIf(Cells(k, str).Resize(8), "<=" & myVal) >= myCnt Then
Set myRng = Cells(k, str).Resize(8)
Exit For
i = k
End If
Next k
If Not myRng Is Nothing Then
For i = k To Cells(Rows.Count, str).End(xlUp).Row Step 8
If WorksheetFunction.CountIf(Cells(i, str).Resize(8), "<=" & myVal) >= myCnt Then
Set myRng = Union(myRng, Cells(i, str).Resize(8))
End If
Next i
End If
myRng.EntireRow.Delete shift:=xlUp
End Sub

こんな感じではどうでしょうか？m(_ _)m

お礼

回答ありがとうございます。

マクロで開くインプットフォーム初めてでした。

こんな事も出来るのですね、内容は、ばっちりでした、ありがとうございました！

回答No.2

kkkkkm

なんとなくこんなのも

Sub Example() 'こちらをボタンに関連付けしてください
Dim LastRpw As Long, StopRow As Long, TopRow As Integer, BottomRow As Integer
Dim mbelow As Single, mNumber As Integer
Dim c As Range
Dim DelCount As Integer

mNumber = 6
mbelow = 0.8

'同じシートで変更することがあるのでしたら上記の変数はセルを参照するかinputboxかユーザーフォームを作って代入してください。
'その時に許容値が入力されたかどうかのチェックもしてください。
'別バージョンが別のシートとか別のファイルでしたら上記の数値をシートごとに変更してください。

TopRow = 1
BottomRow = 8

Call mDelLine(TopRow, BottomRow, mbelow, mNumber)

End Sub

Private Sub mDelLine(ByRef TopRow As Integer, ByRef BottomRow As Integer, ByVal mbelow As Single, ByVal mNumber As Integer)
Dim LastRpw As Long
Dim c As Range
Dim DelCount As Integer
Dim delF As Boolean

With Sheets("Sheet1") '実際のシート名に変更してください。
If .Cells(TopRow, "F") = "" Then
Exit Sub
End If

delF = False
DelCount = 0
For Each c In .Range(.Cells(TopRow, "F"), .Cells(BottomRow, "F"))
If c.Value <= mbelow Then
DelCount = DelCount + 1
If DelCount = mNumber Then
.Range(.Cells(TopRow, "A"), .Cells(BottomRow, "EO")).Delete Shift:=xlUp
delF = True
Exit For
End If
End If
Next
If delF = False Then
TopRow = BottomRow + 1
BottomRow = TopRow + 7
End If

Call mDelLine(TopRow, BottomRow, mbelow, mNumber)

End With
End Sub

お礼

回答ありがとうございます。

おそらく凄く役に立つのでしょうが、内容が把握しづらかったので、No.1さんのやり方をBAとさせて頂きます。

勉強して把握出来る様にしてから見直したいと思います。

ありがとうございました！