Limit .find to one pass

[Robert H]

The following code loops through certain columns and removes the last
character in the data. My data arrangement has changed a little and
now the code continuously loops through the data removing the last
character until there is not data. Its funny to watch but I need to
fix it...

How can I limit the code to make just one pass? Too bad there is not a
"before" attribute.

thanks
Robert

Do Until ActiveCell.Value = ""

Cells.Find(what:="LC", After:=ActiveCell, LookIn:=xlValues,
lookat:= _
xlPart, searchorder:=xlByColumns, SearchDirection:=xlNext,
MatchCase:=
False, SearchFormat:=False).Activate

ActiveCell.Offset(1, 0).Select

Do Until ActiveCell.Value = ""

'Copy the right-most character to the next column
ActiveCell.Offset(0, 1).Value = Right$
(ActiveCell.Value, 1)
'Cut off the right-most character
ActiveCell.Value = Left$(ActiveCell.Value, Len
(ActiveCell.Value) - 1)
'ActiveCell = ActiveCell.Offset(1, 0)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-r, 1).Select 'move up and to next column

Loop

 

[Per Jessen]

Hi Robert

I think this should do it:

Cells.Find(what:="LC", After:=ActiveCell, LookIn:=xlValues, _
lookat:=xlPart, searchorder:=xlByColumns, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate
Set Startcell = ActiveCell
Do
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Value = ""
'Copy the right-most character to the next column
ActiveCell.Offset(0, 1).Value = Right$(ActiveCell.Value, 1)
'Cut off the right-most character
ActiveCell.Value = Left$(ActiveCell.Value, Len(ActiveCell.Value) -
1)
'ActiveCell = ActiveCell.Offset(1, 0)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-r, 1).Select 'move up and to next column
FindNext.Activate
Loop Until ActiveCell.Address = Startcell.Address

Regards,
Per

 

[JE McGimpsey]

One way:

Dim rFound As Range
Dim sAddr As String
With ActiveSheet.Cells
Set rFound = .Find( _
what:="LC", _
after:=.Item(.Rows.Count, .Columns.Count), _
LookIn:=xlValues, _
Lookat:=xlPart, _
searchorder:=xlByColumns, _
searchdirection:=xlNext, _
MatchCase:=False)
If Not rFound Is Nothing Then
sAddr = rFound.Address
Do
With rFound
.Offset(0, 1).Value = Right$(.Text, 1)
.Value = Left$(.Text, Len(.Text) - 1)
End With
Set rFound = .FindNext(after:=rFound)
Loop Until rFound.Address = sAddr

End If
End With

 

[Robert H]

Per, the code manipulates the first column correctly but at the
FindNext.Activate line I'm receiving a Runtime Error 424 "Object
Required" error. I tried to fix it but did not make any progress.
thanks
Robert

 

[Robert H]

Per,
the code manipulates the first column correctly but at the
FindNext.Activate line I'm receiving a Runtime Error 424 "Object
Required" error. I tried to fix it but did not make any progress.
thanks
Robert

 

[Robert H]

JE,
Reading my original post, I realize I did not explain the data
structure.
There is a header row with columns of data below it. I need to find
the columns with "LC" in the header cell and then perform the
manipulation in all the data cells in the column (below the header
cell).

You code sugestion code manipulates the cells containing "LC" in the
header row instead of the cells below the header row.
thanks
Robert

 

[Per Jessen]

Robert

Change
FindNext.Activate

to:

Cells.FindNext.Activate


Regards,
Per

 

[Robert H]

Per, It works now. I had to make one more modification:
Cells.findnext(ActiveCell).Activate
otherwise it would just go back an work the same column one time and
then exit.
Thanks very much for the help
Robert

Final code:

Sub ConvPMFLTSMoveLCIDtoNextCol()

Dim r As Long
Dim r2
Dim startCell As Range
Dim findnext

r = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row - 1

Range("a1").Select

'Code mosdifications from Per Jessen

Cells.Find(what:="LC", After:=ActiveCell, LookIn:=xlValues, _
lookat:=xlPart, searchorder:=xlByColumns, SearchDirection:=xlNext,
_
MatchCase:=False, SearchFormat:=False).Activate

Set startCell = ActiveCell

Do
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Value = ""
'Copy the right-most character to the next column
ActiveCell.Offset(0, 1).Value = Right$(ActiveCell.Value,
1)
'Cut off the right-most character
ActiveCell.Value = Left$(ActiveCell.Value, Len
(ActiveCell.Value) - 1)
'ActiveCell = ActiveCell.Offset(1, 0)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-r, 1).Select 'move up and to next column
Cells.findnext(ActiveCell).Activate
Loop Until ActiveCell.Address = startCell.Address

End Sub

 

[Per Jessen]

Hi Robert

Thanks for your reply, I'm glad you made it work.

Regards,
Per

"Robert H" <[email protected]> skrev i meddelelsen
Per, It works now. I had to make one more modification:
Cells.findnext(ActiveCell).Activate
otherwise it would just go back an work the same column one time and
then exit.
Thanks very much for the help
Robert

Final code:

Sub ConvPMFLTSMoveLCIDtoNextCol()

Dim r As Long
Dim r2
Dim startCell As Range
Dim findnext

r = Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row - 1

Range("a1").Select

'Code mosdifications from Per Jessen

Cells.Find(what:="LC", After:=ActiveCell, LookIn:=xlValues, _
lookat:=xlPart, searchorder:=xlByColumns, SearchDirection:=xlNext,
_
MatchCase:=False, SearchFormat:=False).Activate

Set startCell = ActiveCell

Do
ActiveCell.Offset(1, 0).Select
Do Until ActiveCell.Value = ""
'Copy the right-most character to the next column
ActiveCell.Offset(0, 1).Value = Right$(ActiveCell.Value,
1)
'Cut off the right-most character
ActiveCell.Value = Left$(ActiveCell.Value, Len
(ActiveCell.Value) - 1)
'ActiveCell = ActiveCell.Offset(1, 0)
ActiveCell.Offset(1, 0).Select
Loop
ActiveCell.Offset(-r, 1).Select 'move up and to next column
Cells.findnext(ActiveCell).Activate
Loop Until ActiveCell.Address = startCell.Address

End Sub