エクセルVBAで表から行の削除

質問

添付画像のような表があります。
表はB列の名前でソートされています。
D列の比率をみて、100でないものは、必ず同じ名前で複数行にわかれ合計で100になります。この例では名前CとEとHがそうです。
同じ名前が複数行にわかれている場合、最大の比率の行を残し、他の行（例では、埼玉、栃木、長野、新潟の行）を削除したいのです。
複数行にわかれるのが名前CやEのように2行なら、以下のコードで出来ました。
しかし、めったにはありませんが名前Hのような3行以上に分かれるものには対応できません。
どうすればよいでしょうか？

Sub test01()
　　Dim c As Range
　　Dim Rng As Range
　　Set Rng = Range(Cells(2, "D"), Cells(Rows.Count, "D").End(xlUp))

　　For Each c In Rng '2地区の分担の場合、分担比率高い方を残す。（3地区以上は未対応）2012/08/29
　　　　If c.Value <> 100 And c.Offset(1).Value <> 100 Then
　　　　　　If c.Offset(, -2).Value = c.Offset(1, -2).Value Then
　　　　　　　　If c.Value >= c.Offset(1).Value Then
　　　　　　　　　　c.Offset(1).Value = False
　　　　　　　　Else
　　　　　　　　　　c.Value = False
　　　　　　　　End If
　　　　　　End If
　　　　End If
　　Next
　　If Application.WorksheetFunction.CountIf(Rng, False) > 0 Then
　　　　Rng.SpecialCells(xlCellTypeConstants, xlLogical).EntireRow.Delete
　　End If
End Sub

回答No.1

watabe007 · ベストアンサー

こんばんは
>表はB列の名前でソートされています。
D列もソートすれば楽になると思いますが
Sub Test2()
　　Dim c As Range
　　Dim LastRow As Long, i As Long
　　Dim Tot As Long

　　LastRow = Cells(Rows.Count, "D").End(xlUp).Row
　　Range("A1:D" & LastRow).Sort _
　　Key1:=Range("B1"), Order1:=xlAscending, _
　　Key2:=Range("D1"), Order2:=xlDescending, Header:=xlYes

　　For i = LastRow To 2 Step -1
　　　　 If Tot + Cells(i, "D").Value < 100 Then
　　　　　　Tot = Tot + Cells(i, "D").Value
　　　　　　Cells(i, "D").EntireRow.Delete
　　　　Else
　　　　　　Tot = 0
　　　　End If
　　Next
End Sub

お礼

watabe007さん、さっそくのご回答ありがとうございます。
なあるほど～！
比率も降順で並べ替えしてしまえば下から順に合計100未満を片っ端から消していけばいいわけですね！
勉強になりました。
ありがとうございます。

回答No.2

TAKA_R

Ｂ列が複数あるとき、Ｄ列の中の最高値を残す
Sub test01()
Dim k As Long, g As Long, l As Long, n As Long
Dim brng As Range
Set brng = Range(Cells(2, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2))
k = 1
Do
k = k + 1
g = Application.WorksheetFunction.CountIf(brng, Range("b" & k).Value)
If Not g = 1 Then
l = Application.WorksheetFunction.Max(Range(Cells(k, 4), Cells(k + g - 1, 4)))
n = Application.WorksheetFunction.Match(l, Range(Cells(k, 4), Cells(k + g - 1, 4)), 0) - 1
Rows(k + n).Copy Range("a" & k)
Range(Rows(k + 1), Rows(k + g - 1)).Delete
End If

Loop Until Range("b" & k + 1) = ""
End Sub

ですが、ＮＯ１さんが言っているように「Ｂ列昇順、Ｄ列降順」で並び替えておくと、
こんなに簡単なコードになります。
Sub test02()
Dim k As Long, g As Long
k = 1
Do
k = k + 1
g = Application.WorksheetFunction.CountIf(Range(Cells(2, 2), Cells(Cells(Rows.Count, 2).End(xlUp).Row, 2)), Range("b" & k).Value)
If Not g = 1 Then Range(Rows(k + 1), Rows(k + g - 1)).Delete
Loop Until Range("b" & k + 1) = ""
End Sub

お礼

TAKA_Rさん、ありがとうございます。
とても勉強になりました。