macro to find extract and paste contents from one cell to another
 

Hi all,
Below is a sample of a cell:

Families with pets CHAPTER 1

I need to locate this cell, by searching for the "CHAPTER" text,
extract everything but CHAPTER 1, paste it in the cell adjacent to it,
leaving the original cell with "CHAPTER 1" only and "Families with
pets" will be in the next cell over, then color the entire row.

Here is what i have so far: from here i am at a loss. any help would be
much appreciated

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(cell.Value, myword)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.Copy
cell.Offset(0, 1).PasteSpecial
cell.Offset(0, 0).Value = myword
cell.Offset(0, 1).Characters(start_str, Mylen).Delete
End If
Next
End Sub

God bless
jsd219

macro to find extract and paste contents from one cell to another
 

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value = Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - Iloc)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ups.com...
Hi all,
Below is a sample of a cell:

Families with pets CHAPTER 1

I need to locate this cell, by searching for the "CHAPTER" text,
extract everything but CHAPTER 1, paste it in the cell adjacent to it,
leaving the original cell with "CHAPTER 1" only and "Families with
pets" will be in the next cell over, then color the entire row.

Here is what i have so far: from here i am at a loss. any help would be
much appreciated

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(cell.Value, myword)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.Copy
cell.Offset(0, 1).PasteSpecial
cell.Offset(0, 0).Value = myword
cell.Offset(0, 1).Characters(start_str, Mylen).Delete
End If
Next
End Sub

God bless
jsd219

macro to find extract and paste contents from one cell to another
 

Thank you, only one problem left. It is not deleting the moved text
from the orginal cell.
Any ideas?

God bless
jsd219


Tom Ogilvy wrote:
Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value = Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - Iloc)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ups.com...
Hi all,
Below is a sample of a cell:

Families with pets CHAPTER 1

I need to locate this cell, by searching for the "CHAPTER" text,
extract everything but CHAPTER 1, paste it in the cell adjacent to it,
leaving the original cell with "CHAPTER 1" only and "Families with
pets" will be in the next cell over, then color the entire row.

Here is what i have so far: from here i am at a loss. any help would be
much appreciated

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(cell.Value, myword)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.Copy
cell.Offset(0, 1).PasteSpecial
cell.Offset(0, 0).Value = myword
cell.Offset(0, 1).Characters(start_str, Mylen).Delete
End If
Next
End Sub

God bless
jsd219

macro to find extract and paste contents from one cell to another
 

I changed the line below
from :
cell.Value = Right(cell.Value, Len(cell.Value) - Iloc)
to:
cell.Value = Right(cell.Value, Len(myword) - Iloc)

It is working but it cuts off the first two letters.

Tom Ogilvy wrote:
Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value = Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - Iloc)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ups.com...
Hi all,
Below is a sample of a cell:

Families with pets CHAPTER 1

I need to locate this cell, by searching for the "CHAPTER" text,
extract everything but CHAPTER 1, paste it in the cell adjacent to it,
leaving the original cell with "CHAPTER 1" only and "Families with
pets" will be in the next cell over, then color the entire row.

Here is what i have so far: from here i am at a loss. any help would be
much appreciated

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(cell.Value, myword)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.Copy
cell.Offset(0, 1).PasteSpecial
cell.Offset(0, 0).Value = myword
cell.Offset(0, 1).Characters(start_str, Mylen).Delete
End If
Next
End Sub

God bless
jsd219

macro to find extract and paste contents from one cell to another
 

I figured it out, thank you so much. :-)

God bless
jsd219


Tom Ogilvy wrote:
Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value = Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - Iloc)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ups.com...
Hi all,
Below is a sample of a cell:

Families with pets CHAPTER 1

I need to locate this cell, by searching for the "CHAPTER" text,
extract everything but CHAPTER 1, paste it in the cell adjacent to it,
leaving the original cell with "CHAPTER 1" only and "Families with
pets" will be in the next cell over, then color the entire row.

Here is what i have so far: from here i am at a loss. any help would be
much appreciated

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(cell.Value, myword)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.Copy
cell.Offset(0, 1).PasteSpecial
cell.Offset(0, 0).Value = myword
cell.Offset(0, 1).Characters(start_str, Mylen).Delete
End If
Next
End Sub

God bless
jsd219

macro to find extract and paste contents from one cell to another
 

Just a typo: I used my usual variable instead of the one you are using. I
also adjusted the formula.

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value = Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - start_Str + 1)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ps.com...
Thank you, only one problem left. It is not deleting the moved text
from the orginal cell.
Any ideas?

God bless
jsd219


Tom Ogilvy wrote:
Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value = Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - Iloc)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ups.com...
Hi all,
Below is a sample of a cell:

Families with pets CHAPTER 1

I need to locate this cell, by searching for the "CHAPTER" text,
extract everything but CHAPTER 1, paste it in the cell adjacent to it,
leaving the original cell with "CHAPTER 1" only and "Families with
pets" will be in the next cell over, then color the entire row.

Here is what i have so far: from here i am at a loss. any help would be
much appreciated

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(cell.Value, myword)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.Copy
cell.Offset(0, 1).PasteSpecial
cell.Offset(0, 0).Value = myword
cell.Offset(0, 1).Characters(start_str, Mylen).Delete
End If
Next
End Sub

God bless
jsd219

macro to find extract and paste contents from one cell to another
 

is there a way to account for and eliminate the extra space caused by a
double digit number?
I changed this line to read: cell.value =
Right(cell.Value,len(Cell.Value) - start_Str + 3)

in order to account for double digit numbers but what happens is
everycell with single digit numbers now has a space at the begining,
i.e.

Families with Dogs Chapter 10

comes out:
Chapter 10 Families with Dogs

Families with Dogs Chapter 9

comes out:
Chapter 9 Families with Dogs

I now have a space before Chapter 9

i know i could just go in an change this manually but i have several
spread sheets with all kinds of scripts, formulas and functions
running. trying to remeber little things like that will cost me down
the line. :-)

Tom Ogilvy wrote:
Just a typo: I used my usual variable instead of the one you are using. I
also adjusted the formula.

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value = Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - start_Str + 1)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ps.com...
Thank you, only one problem left. It is not deleting the moved text
from the orginal cell.
Any ideas?

God bless
jsd219


Tom Ogilvy wrote:
Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value = Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - Iloc)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ups.com...
Hi all,
Below is a sample of a cell:

Families with pets CHAPTER 1

I need to locate this cell, by searching for the "CHAPTER" text,
extract everything but CHAPTER 1, paste it in the cell adjacent to it,
leaving the original cell with "CHAPTER 1" only and "Families with
pets" will be in the next cell over, then color the entire row.

Here is what i have so far: from here i am at a loss. any help would be
much appreciated

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(cell.Value, myword)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.Copy
cell.Offset(0, 1).PasteSpecial
cell.Offset(0, 0).Value = myword
cell.Offset(0, 1).Characters(start_str, Mylen).Delete
End If
Next
End Sub

God bless
jsd219

macro to find extract and paste contents from one cell to another
 

If you have a space after the 9, it is because the original had a space
after the 9. Changing + 1 to + 3 should pick up an additional two
characters to the left of Chapter.

cell.value = Trim(Right(cell.Value,len(Cell.Value) - start_Str + 1))

is perhaps what you want


Just to demo changing +1 to + 3 from the immediate window:

s = "Cats and Dogs Chapter 10"
iloc = Instr(1,s,"chapter",vbTextCompare)
? iloc
15
? "==" & right(s,len(s) - iloc + 1) & "<=="
==Chapter 10<==
? "==" & right(s,len(s) - iloc + 3) & "<=="
==s Chapter 10<==

Now demonstarting that it doesn't put a space after the 9:

s = Replace(s,"10","9")
? s
Cats and Dogs Chapter 9
? "==" & right(s,len(s) - iloc + 1) & "<=="
==Chapter 9<==

However, if the 9 already has a space after it:

s = Replace(s,"9","9 ")
? s & "<==="
Cats and Dogs Chapter 9 <===
? "==" & right(s,len(s) - iloc + 1) & "<=="
==Chapter 9 <==

But adding trim when the space already exists:

? "==" & Trim(right(s,len(s) - iloc + 1)) & "<=="
==Chapter 9<==


--
Regards,
Tom Ogilvy


"jsd219" wrote in message
oups.com...
is there a way to account for and eliminate the extra space caused by a
double digit number?
I changed this line to read: cell.value =
Right(cell.Value,len(Cell.Value) - start_Str + 3)

in order to account for double digit numbers but what happens is
everycell with single digit numbers now has a space at the begining,
i.e.

Families with Dogs Chapter 10

comes out:
Chapter 10 Families with Dogs

Families with Dogs Chapter 9

comes out:
Chapter 9 Families with Dogs

I now have a space before Chapter 9

i know i could just go in an change this manually but i have several
spread sheets with all kinds of scripts, formulas and functions
running. trying to remeber little things like that will cost me down
the line. :-)

Tom Ogilvy wrote:
Just a typo: I used my usual variable instead of the one you are using.
I
also adjusted the formula.

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value = Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - start_Str +
1)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ps.com...
Thank you, only one problem left. It is not deleting the moved text
from the orginal cell.
Any ideas?

God bless
jsd219


Tom Ogilvy wrote:
Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value =
Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - Iloc)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ups.com...
Hi all,
Below is a sample of a cell:

Families with pets CHAPTER 1

I need to locate this cell, by searching for the "CHAPTER" text,
extract everything but CHAPTER 1, paste it in the cell adjacent to
it,
leaving the original cell with "CHAPTER 1" only and "Families with
pets" will be in the next cell over, then color the entire row.

Here is what i have so far: from here i am at a loss. any help would
be
much appreciated

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(cell.Value, myword)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.Copy
cell.Offset(0, 1).PasteSpecial
cell.Offset(0, 0).Value = myword
cell.Offset(0, 1).Characters(start_str, Mylen).Delete
End If
Next
End Sub

God bless
jsd219

macro to find extract and paste contents from one cell to another
 

My appologies i got a bit lost there but the new line worked like a
charm. :-)

Thank you very much

God bless
jsd219

Tom Ogilvy wrote:
If you have a space after the 9, it is because the original had a space
after the 9. Changing + 1 to + 3 should pick up an additional two
characters to the left of Chapter.

cell.value = Trim(Right(cell.Value,len(Cell.Value) - start_Str + 1))

is perhaps what you want


Just to demo changing +1 to + 3 from the immediate window:

s = "Cats and Dogs Chapter 10"
iloc = Instr(1,s,"chapter",vbTextCompare)
? iloc
15
? "==" & right(s,len(s) - iloc + 1) & "<=="
==Chapter 10<==
? "==" & right(s,len(s) - iloc + 3) & "<=="
==s Chapter 10<==

Now demonstarting that it doesn't put a space after the 9:

s = Replace(s,"10","9")
? s
Cats and Dogs Chapter 9
? "==" & right(s,len(s) - iloc + 1) & "<=="
==Chapter 9<==

However, if the 9 already has a space after it:

s = Replace(s,"9","9 ")
? s & "<==="
Cats and Dogs Chapter 9 <===
? "==" & right(s,len(s) - iloc + 1) & "<=="
==Chapter 9 <==

But adding trim when the space already exists:

? "==" & Trim(right(s,len(s) - iloc + 1)) & "<=="
==Chapter 9<==


--
Regards,
Tom Ogilvy


"jsd219" wrote in message
oups.com...
is there a way to account for and eliminate the extra space caused by a
double digit number?
I changed this line to read: cell.value =
Right(cell.Value,len(Cell.Value) - start_Str + 3)

in order to account for double digit numbers but what happens is
everycell with single digit numbers now has a space at the begining,
i.e.

Families with Dogs Chapter 10

comes out:
Chapter 10 Families with Dogs

Families with Dogs Chapter 9

comes out:
Chapter 9 Families with Dogs

I now have a space before Chapter 9

i know i could just go in an change this manually but i have several
spread sheets with all kinds of scripts, formulas and functions
running. trying to remeber little things like that will cost me down
the line. :-)

Tom Ogilvy wrote:
Just a typo: I used my usual variable instead of the one you are using.
I
also adjusted the formula.

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value = Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - start_Str +
1)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ps.com...
Thank you, only one problem left. It is not deleting the moved text
from the orginal cell.
Any ideas?

God bless
jsd219


Tom Ogilvy wrote:
Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value =
Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - Iloc)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ups.com...
Hi all,
Below is a sample of a cell:

Families with pets CHAPTER 1

I need to locate this cell, by searching for the "CHAPTER" text,
extract everything but CHAPTER 1, paste it in the cell adjacent to
it,
leaving the original cell with "CHAPTER 1" only and "Families with
pets" will be in the next cell over, then color the entire row.

Here is what i have so far: from here i am at a loss. any help would
be
much appreciated

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(cell.Value, myword)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.Copy
cell.Offset(0, 1).PasteSpecial
cell.Offset(0, 0).Value = myword
cell.Offset(0, 1).Characters(start_str, Mylen).Delete
End If
Next
End Sub

God bless
jsd219

macro to find extract and paste contents from one cell to another
 

I love the script and it is working great. i have a new issue. i have
duplicated the script for another cell but this one is in reversed
order. With this cell i need to keep "MONTH 1" in its current cell and
move "90-Second Speach" to the adjacent cell i tried swithing these two
lines from:

MONTH 1 90-Second Speach

cell.Offset(0, 1).Value = Trim(Left(cell.Value, start_str - 1))
cell.Value = Trim(Right(cell.Value, Len(cell.Value) -
start_str + 1))
to:
cell.Offset(0, 1).Value = Trim(Right(cell.Value, Len(cell.Value) -
start_str - 7))
cell.Value = Trim(Left(cell.Value, Len(myword) + start_str
+ 2))

I am sure there is a cleaner way of doing this though. I don't like
having to place a 7 and a 2 in order to get the proper string. Can you
help with this as well?

God bless
jsd219


Tom Ogilvy wrote:
If you have a space after the 9, it is because the original had a space
after the 9. Changing + 1 to + 3 should pick up an additional two
characters to the left of Chapter.

cell.value = Trim(Right(cell.Value,len(Cell.Value) - start_Str + 1))

is perhaps what you want


Just to demo changing +1 to + 3 from the immediate window:

s = "Cats and Dogs Chapter 10"
iloc = Instr(1,s,"chapter",vbTextCompare)
? iloc
15
? "==" & right(s,len(s) - iloc + 1) & "<=="
==Chapter 10<==
? "==" & right(s,len(s) - iloc + 3) & "<=="
==s Chapter 10<==

Now demonstarting that it doesn't put a space after the 9:

s = Replace(s,"10","9")
? s
Cats and Dogs Chapter 9
? "==" & right(s,len(s) - iloc + 1) & "<=="
==Chapter 9<==

However, if the 9 already has a space after it:

s = Replace(s,"9","9 ")
? s & "<==="
Cats and Dogs Chapter 9 <===
? "==" & right(s,len(s) - iloc + 1) & "<=="
==Chapter 9 <==

But adding trim when the space already exists:

? "==" & Trim(right(s,len(s) - iloc + 1)) & "<=="
==Chapter 9<==


--
Regards,
Tom Ogilvy


"jsd219" wrote in message
oups.com...
is there a way to account for and eliminate the extra space caused by a
double digit number?
I changed this line to read: cell.value =
Right(cell.Value,len(Cell.Value) - start_Str + 3)

in order to account for double digit numbers but what happens is
everycell with single digit numbers now has a space at the begining,
i.e.

Families with Dogs Chapter 10

comes out:
Chapter 10 Families with Dogs

Families with Dogs Chapter 9

comes out:
Chapter 9 Families with Dogs

I now have a space before Chapter 9

i know i could just go in an change this manually but i have several
spread sheets with all kinds of scripts, formulas and functions
running. trying to remeber little things like that will cost me down
the line. :-)

Tom Ogilvy wrote:
Just a typo: I used my usual variable instead of the one you are using.
I
also adjusted the formula.

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value = Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - start_Str +
1)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ps.com...
Thank you, only one problem left. It is not deleting the moved text
from the orginal cell.
Any ideas?

God bless
jsd219


Tom Ogilvy wrote:
Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(1,cell.Value, myword,vbTextCompare)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.offset(0,1).Value =
Trim(Left(cell.Value,start_str-1))
cell.value = Right(cell.Value,len(Cell.Value) - Iloc)
End If
Next
End Sub

--
Regards,
Tom Ogilvy


"jsd219" wrote in message
ups.com...
Hi all,
Below is a sample of a cell:

Families with pets CHAPTER 1

I need to locate this cell, by searching for the "CHAPTER" text,
extract everything but CHAPTER 1, paste it in the cell adjacent to
it,
leaving the original cell with "CHAPTER 1" only and "Families with
pets" will be in the next cell over, then color the entire row.

Here is what i have so far: from here i am at a loss. any help would
be
much appreciated

Sub FindMoveColor()
Dim rng As Range
Dim cell As Range
Dim start_str As Integer

myword = InputBox("Enter the search string ")
Mylen = Len(myword)

With Worksheets(InputBox("Enter the Worksheet"))
Set rng = .Range("N1", .Cells(.Rows.Count, "N").End(xlUp))
End With
For Each cell In rng
start_str = InStr(cell.Value, myword)
If start_str Then
cell.EntireRow.Interior.Color = RGB(204, 255, 204)
cell.Copy
cell.Offset(0, 1).PasteSpecial
cell.Offset(0, 0).Value = myword
cell.Offset(0, 1).Characters(start_str, Mylen).Delete
End If
Next
End Sub

God bless
jsd219