Option Explicit
Sub SortMaKH()
Const BaTram As Double = 3 * 10 ^ 8
Dim Rng As Range, sRng As Range, Clls As Range, mRng As Range
Dim SoDu As Double, sMax As Double, eRw As Long
Dim MyAdd As String, Sh As Worksheet
Sheets("S1").Select: Set Sh = Sheets("S2")
Application.ScreenUpdating = False
Set Rng = Range([c1], [c65500].End(xlUp))
Columns("B:I").Sort Key1:=[C2], Order1:=xlAscending, Key2:=[D2] _
, Order2:=xlAscending, Header:=xlGuess
Rng.AdvancedFilter Action:=2, CopyToRange:=[N1], Unique:=True
Sh.[B1].CurrentRegion.Offset(1, 1).ClearContents
For Each Clls In Range([N2], [n65500].End(xlUp))
Set sRng = Rng.Find(Clls.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address: sMax = 0
SoDu = 0
Do
SoDu = SoDu + sRng.Offset(, 6).Value
If sRng.Offset(, 6).Value > sMax Then
sMax = sRng.Offset(, 6).Value: Set mRng = sRng
End If
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
If SoDu >= BaTram Then
With Sh.[c65500].End(xlUp).Offset(1)
.Offset(, -1).Resize(, 8).Value = mRng.Offset(, -1).Resize(, 8).Value
If mRng.Offset(, 6) < BaTram Then _
.Interior.ColorIndex = 35 + .Row Mod 6
Set mRng = Nothing
End With
End If
End If
Next Clls
Sh.Select: Set Sh = Nothing
End Sub