Macro to Find, Cut, and Paste
 

I have 2 LONG columns that I need to make into MANY. I want to find a word in
the active column, cut from that word down to the end and the adjacent cells;
then paste them at the top of the next column. and do this for all occurences
of that word.

I'm confused about the two columns. I'm thinking that you want to break up your
list of two columns based on the word in column A.

But paste both columns to the adjacent columns.

So this:

$H$1 $B$1
$H$2 $B$2
$H$3 $B$3
$H$4 $B$4
$H$5 $B$5
$H$6 $B$6
$H$7 $B$7
aaaa $B$8
$H$9 $B$9
$H$10 $B$10
$H$11 $B$11
$H$12 $B$12
$H$13 $B$13
$H$14 $B$14
$H$15 $B$15
aaaa $B$16
$H$17 $B$17
$H$18 $B$18
$H$19 $B$19
$H$20 $B$20
$H$21 $B$21
$H$22 $B$22
aaaa $B$23
$H$24 $B$24
$H$25 $B$25
$H$26 $B$26
$H$27 $B$27
$H$28 $B$28
$H$29 $B$29
$H$30 $B$30

Would become (broken by aaaa in column A) this:

$H$1 $B$1 aaaa $B$8 aaaa $B$16 aaaa $B$23
$H$2 $B$2 $H$9 $B$9 $H$17 $B$17 $H$24 $B$24
$H$3 $B$3 $H$10 $B$10 $H$18 $B$18 $H$25 $B$25
$H$4 $B$4 $H$11 $B$11 $H$19 $B$19 $H$26 $B$26
$H$5 $B$5 $H$12 $B$12 $H$20 $B$20 $H$27 $B$27
$H$6 $B$6 $H$13 $B$13 $H$21 $B$21 $H$28 $B$28
$H$7 $B$7 $H$14 $B$14 $H$22 $B$22 $H$29 $B$29
$H$15 $B$15 $H$30 $B$30


If that's close, try this against a copy of your worksheet.

Option Explicit
Sub testme01()

Dim wks As Worksheet
Dim myWord As String
Dim FoundCell As Range
Dim CountOfWords As Long
Dim rngToCopy As Range
Dim cCtr As Long

Set wks = Worksheets("sheet1")

'What's the word????
myWord = "aaaa"

cCtr = 0

With wks
CountOfWords = Application.CountIf(.Range("a:a"), myWord)
Do
With .Range("a:a")
Set FoundCell = .Cells.Find(what:=myWord, _
after:=.Cells(1), LookIn:=xlValues, _
lookat:=xlWhole, searchorder:=xlByRows, _
searchdirection:=xlPrevious, _
MatchCase:=False)
End With

If FoundCell Is Nothing Then
'we're done
Exit Do
End If

Set rngToCopy = .Range(FoundCell, _
.Cells(.Rows.Count, "a").End(xlUp))

rngToCopy.Resize(, 2).Cut _
Destination:=.Cells(1, 2 * CountOfWords + 1 - cCtr)

cCtr = cCtr + 2
Loop
End With

End Sub

Rob wrote:

I have 2 LONG columns that I need to make into MANY. I want to find a word in
the active column, cut from that word down to the end and the adjacent cells;
then paste them at the top of the next column. and do this for all occurences
of that word.

--

Dave Peterson

That is exactly what i want to do, but your code gave me an error at line:
rngToCopy.Resize(, 2).Cut _
Destination:=.Cells(1, 2 * CountOfWords + 1 - cCtr)
I had already figured out a pretty easy way to do it in the meantime, but
now i need the loop... as my code only does one instance at a time. here is
what I had come up with:
Sub FirstTry()
Dim ObjKeyCell
Dim X
Dim Y
Dim Z
Set ObjKeyCell = Cells.Find(what:="Subject:", after:=ActiveCell,
searchorder:=xlByColumns, searchdirection:=xlNext)
Set X = ObjKeyCell
Set Y = X.Next
Set Z = Y.Next
Range(X, Y).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Z.Select
Selection.End(xlUp).Select
ActiveSheet.Paste
End Sub

That code worked ok for me. I started at the bottom and worked up. I thought
it would be easier.

You may want to paste the code you used. (I suspect a change.)

Rob wrote:

That is exactly what i want to do, but your code gave me an error at line:
rngToCopy.Resize(, 2).Cut _
Destination:=.Cells(1, 2 * CountOfWords + 1 - cCtr)
I had already figured out a pretty easy way to do it in the meantime, but
now i need the loop... as my code only does one instance at a time. here is
what I had come up with:
Sub FirstTry()
Dim ObjKeyCell
Dim X
Dim Y
Dim Z
Set ObjKeyCell = Cells.Find(what:="Subject:", after:=ActiveCell,
searchorder:=xlByColumns, searchdirection:=xlNext)
Set X = ObjKeyCell
Set Y = X.Next
Set Z = Y.Next
Range(X, Y).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Cut
Z.Select
Selection.End(xlUp).Select
ActiveSheet.Paste
End Sub

--

Dave Peterson