Sub toto()
Dim i&, j&, k&, r&, Plg As Range, v, w()
Const offsetCol& = 7
Set Plg = Intersect(ActiveSheet.Columns("B").Cells, Selection)
If Not Plg Is Nothing Then
If Plg.Count > 1 Then
r = Plg(1).Row + Plg.Count - 1
ReDim w(1 To Plg.Count, 0)
For i = 1 To Plg.Count
If Not IsEmpty(Plg(i).Value) Then
j = 0
Do
v = Empty
j = j + 1
If IsNumeric(Plg(i).Offset(j, offsetCol).Value) Then v = Plg(i).Offset(j, offsetCol).Value: Exit Do
Loop While i + j < r
If Not IsEmpty(v) Then
Do: j = j + 1: Loop While (IsEmpty(Plg(i).Offset(j, offsetCol).Value) Or v = Plg(i).Offset(j, offsetCol).Value) And IsEmpty(Plg(i + j).Value) And i + j < r
If IsEmpty(Plg(i + j).Value) Then If v <> Plg(i).Offset(j, offsetCol).Value Then k = k + 1: w(k, 0) = Plg(i).Offset(j, offsetCol).Value
End If
i = i + j - 1
Else
End If
Next
With ActiveSheet.[M2]
Intersect(.CurrentRegion, .Parent.Columns(.Column)).Offset(1).ClearContents
If k Then .Cells.Resize(k, 1).Value = w
End With
End If
End If
End Sub