How to get my code to loop

[Dominique Feteau]

I have a macro that will search Column A for the word "Diary", select that
cell, and move the contents of that cell over 4 columns. I want it to look
through the entire column and continue till it doesnt find the word "diary"
in column A. How do I do that?

Sub Move()

Columns("A:A").Select
Cells.Find(What:="Diary", After:=ActiveCell, LookIn:=xlFormulas, LookAt
_
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:= _
False, SearchFormat:=False).Activate
Selection.Cut
ActiveCell.Offset(columnOffset:=4).Activate
ActiveSheet.Paste

End Sub

 

[R.VENKATARAMAN]

many solutions
your data is A3 to A10
try this macro

Option Explicit

Public Sub test()
Dim cell As Range
For Each cell In Range("a3:a10")
If cell = "dairy" Then cell.Offset(0, 4) = cell
Next
End Sub

the statement after <then> can be any action

=======================

 

[Dominique Feteau]

This idea works, but not how i need it to work. the reason i used the .find
method is because "Diary" is the first word in each cell that I want moved
to the 4th column. for example: in A2 = Diary Date 510, in A45 = Diary Date
520. I did create a slimmed down version of my macro, but still cant figure
out how to make it loop.

Sub Move()

Columns("A:A").Select
Cells.Find(What:="Diary", After:=ActiveCell, LookIn:=xlValues).Activate
Selection.Cut
ActiveCell.Offset(columnOffset:=4).Activate
ActiveSheet.Paste

End Sub

 

[Norman Jones]

Hi Dominique,

Using the Find/FindNext method, try:

Sub Move()
Dim c As Range
Dim firstAddress As String
Dim rng As Range
Dim sStr As String
sStr = "Diary"
With ActiveSheet.Columns("A:A")
On Error Resume Next
Set c = .Find(What:=sStr, _
After:=ActiveSheet.Range("A1"), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False, _
SearchFormat:=False)
On Error GoTo 0
If Not c Is Nothing Then
firstAddress = c.Address
Do
If Not rng Is Nothing Then
Set rng = Union(rng, c)
Else
Set rng = c
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address _
<> firstAddress
rng.ClearContents
rng.Offset(0, 4) = sStr
End If
End With
End Sub

 

[Bob Phillips]

Dominique.

Try this

Sub Move()
Dim oCell As Range
Dim sStart As String
With Columns("A:A")
Set oCell = .Find(What:="Diary")
If Not oCell Is Nothing Then
Do
oCell.Copy Destination:=oCell.Offset(0, 4)
oCell.Value = ""
sStart = oCell.Address
Set oCell = .FindNext(oCell)
Loop While Not oCell Is Nothing
End If
End With

End Sub



--

HTH

RP
(remove nothere from the email address if mailing direct)

 

[Dominique Feteau]

Thanks Bob. I was so close.

Dominique

Dominique.

Try this

Sub Move()
Dim oCell As Range
Dim sStart As String
With Columns("A:A")
Set oCell = .Find(What:="Diary")
If Not oCell Is Nothing Then
Do
oCell.Copy Destination:=oCell.Offset(0, 4)
oCell.Value = ""
sStart = oCell.Address
Set oCell = .FindNext(oCell)
Loop While Not oCell Is Nothing
End If
End With

End Sub



--

HTH

RP
(remove nothere from the email address if mailing direct)