Find, Select, and Move

[bastet8300]

I have data that is a bit of a mess. I need to find a set phrase (SSN which is always in Column D, select that and the five cells following it, cut it, and copy it into the line above starting with cell J. then loop it around to find the next instance and so on and so on. I then need to do the same thing for a set phrase (Chart # which is always in column E, select it and the five cells following it, cut them, and copy them to the same line mentioned above, which would be two lines above the line where Chart # starts. That one would go into cell P and to the right. Then loop this as well to do this through the rest of the doc.

Any help would be greatly appreciated!

 

[JLGWhiz]

try this

Sub t()
Dim fn As Range, adr As String, c As Range
With ActiveSheet
    Set fn = .Range("D2", .Cells(Rows.Count, 4).End(xlUp)).Find("SSN", , xlValues, xlWhole)
        If Not fn Is Nothing Then
            adr = fn.Address
            Do
                fn.Resize(, 6).Copy fn.Offset(-1, 6)
                Set fn = .FindNext(fn)
            Loop While fn.Address <> adr
            Set fn = Nothing
            For Each c In .Range("D2", .Cells(Rows.Count, 4).End(xlUp))
                If c.Value = "SSN" Then c.Resize(, 6).ClearContents
            Next
        End If
    Set fn = .Range("E2", .Cells(Rows.Count, 5).End(xlUp)).Find("Chart #", , xlValues, xlWhole)
        If Not fn Is Nothing Then
            adr = fn.Address
            Do
                fn.Resize(, 6).Copy fn.Offset(-2, 11)
                Set fn = .Range("E2", .Cells(Rows.Count, 5).End(xlUp)).FindNext(fn)
            Loop While fn.Address <> adr
            Set fn = Nothing
            For Each c In .Range("E2", .Cells(Rows.Count, 5).End(xlUp))
                If c.Value = "Chart #" Then c.Resize(, 6).ClearContents
            Next
        End If
End With
End Sub

 

[bastet8300]

Sorry, those are supposed to be : ) and not smilies above.

try this

Sub t()
Dim fn As Range, adr As String, c As Range
With ActiveSheet
    Set fn = .Range("D2", .Cells(Rows.Count, 4).End(xlUp)).Find("SSN", , xlValues, xlWhole)
        If Not fn Is Nothing Then
            adr = fn.Address
            Do
                fn.Resize(, 6).Copy fn.Offset(-1, 6)
                Set fn = .FindNext(fn)
            Loop While fn.Address <> adr
            Set fn = Nothing
            For Each c In .Range("D2", .Cells(Rows.Count, 4).End(xlUp))
                If c.Value = "SSN" Then c.Resize(, 6).ClearContents
            Next
        End If
    Set fn = .Range("E2", .Cells(Rows.Count, 5).End(xlUp)).Find("Chart #", , xlValues, xlWhole)
        If Not fn Is Nothing Then
            adr = fn.Address
            Do
                fn.Resize(, 6).Copy fn.Offset(-2, 11)
                Set fn = .Range("E2", .Cells(Rows.Count, 5).End(xlUp)).FindNext(fn)
            Loop While fn.Address <> adr
            Set fn = Nothing
            For Each c In .Range("E2", .Cells(Rows.Count, 5).End(xlUp))
                If c.Value = "Chart #" Then c.Resize(, 6).ClearContents
            Next
        End If
End With
End Sub

Thanks! I will try it tomorrow!!