Perhaps this:

Sub FixData()
Dim Rng1 As Range, Rng2 As Range
Dim C As Range, DeleteRng As Range
Dim FirstAdd As String

Application.ScreenUpdating = False
Set Rng1 = ActiveSheet.Columns("B")
Set C = Rng1.Find("Group", LookIn:=xlValues)
If Not C Is Nothing Then
FirstAdd = C.Address
Set Rng2 = Range(C.Offset(, 2), C.Offset(, 7))
Do
Set C = C.Offset(1)
If LCase(Trim(C.Value)) = "group member" Then _
Range(C.Offset(, 2), C.Offset(, 7)) = Rng2.Value
Loop Until LCase(Trim(C.Value)) < "group member"
Set DeleteRng = Rng2.EntireRow
End If

Do
Set C = Rng1.FindNext(C)
If C.Address = FirstAdd Then Exit Do
Set Rng2 = Range(C.Offset(, 2), C.Offset(, 7))
Do
Set C = C.Offset(1)
If LCase(Trim(C.Value)) = "group member" Then _
Range(C.Offset(, 2), C.Offset(, 7)) = Rng2.Value
Loop Until LCase(Trim(C.Value)) < "group member"
Set DeleteRng = Union(DeleteRng, Rng2.EntireRow)
Loop While Not C Is Nothing
DeleteRng.Delete
Columns("B").EntireColumn.Delete
Application.ScreenUpdating = True
End Sub

Note that the code is designed to be case insensitive and to ignor
leading and/or trailing spaces in case of sloppy typing.

Regards,
Greg
:

--
Message posted from http://www.ExcelForum.com