Search for word and copy

[hifrommars]

Hi All
I am doing this from home having spent the best part of the day
cutting and pasting data which I know can be done by VB but alas my VB
skills have never been good so any help would be brilliant!!!
I have a column of data imported from a text file with the start of
each line of cells numbered "Part 1" then 5 rows of data beneath then
"Part 2" followed by 4 rows of data, then "Part 3" and so on. The rows
of data all in Column A vary in size.
Is it possible to write a macro that will search for say "Part" find
the next then copy the cells to include the first "Part" plus cells up
to but not the next "Part" take this information to another worksheet
transpose it so that it is now in a row then loop back until there is
no more data to copy?

I have tried searching but have not had much success.

Many thanks in advance.


Mars

 

[Bernie Deitrick]

Mars,

I have assumed that your data is in column A.

Make a copy of your sheet. On the copied sheet, if your values start in
Cell A2, in cell B2 insert the formula

=IF(AND(LEFT($A2,4)="Part",LEFT(OFFSET($A2,COLUMN(A1),0),4)<>"Part"),OFFSET($A2,COLUMN(A1),0),"")

and copy to C2:F2, then copy B2:F2 down the column to match your data.

(If your data starts in another row, change all the A2s to A? Leave the A1s
alone....)

Then copy columns B to F and paste special values to get rid of the
formulas, sort your entire sheet based on column B, get rid of the rows
where B is blank, then re-sort based on column A. And you're done.

HTH,
Bernie
MS Excel MVP

 

[Mars]

Bernie
Thank you for replying and apologies for delay in response. I'm afraid I
couldn't get this to work. Yes all the data is within one column.
Is there another method that you are aware of?


Mars

 

[Bernie Deitrick]

Mars,

Try a macro, below.

HTH,
Bernie
MS Excel MVP


Sub MarsMacro()
Dim myC1 As Range
Dim myC2 As Range
Dim myAdd As String

Set myC1 = Columns("A:A").Find(What:="Part")
myAdd = myC1.Address
While Not myC1 Is Nothing
Set myC2 = Columns("A:A").FindNext(After:=myC1)
If Not myC2 Is Nothing And myC2.Address <> myAdd Then
Range(myC1(2), myC2(0)).Copy
myC1(1, 2).PasteSpecial xlPasteValues, , , True
Set myC1 = myC2
Else
Range(myC1(2), Cells(Rows.Count, 1).End(xlUp)).Copy
myC1(1, 2).PasteSpecial xlPasteValues, , , True
GoTo Finished:
End If
Wend
Finished:

Range(Range(myAdd), Cells(Rows.Count, 1).End(xlUp)). _
Offset(0, 1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End Sub

 

[Mars]

Bernie
Genius - you have no idea how helpful this is.
Thanks and thanks again.

Regards

Mars

 

[Bernie Deitrick]

Mars,

Genius - you have no idea how helpful this is.
Thanks and thanks again.

Glad to hear it, and thanks for letting me know.

Bernie
MS Excel MVP