Is there any faster version of my Code??

[PritishS]

Dear Sirs/Madams,
I have a code which search for a specific text 'PEN COLOR' in column 2, select that cell and 1 cell to right, then cut the selection and paste 1 cell right to the same row. My code works fine for small amount of data ( or rows (around 1000 rows), but when it goes for large number of rows then it's taking several minutes. Can anyone please suggest any betterment in this below code?

Sub Move_Pen_Name()
    Dim ws As Worksheet
    Dim aCell As Range
    Dim i As Long
Application.ScreenUpdating = False
    Set ws = ActiveSheet
For i = 1 To Rows.Count
    With ws
        Set aCell = .Columns(2).Find(What:="PEN COLOR", LookIn:=xlValues, _
                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=True, SearchFormat:=False)
        If Not aCell Is Nothing Then
            aCell.Select
            ActiveCell.Offset(, 1).Resize(1, 1).Cut
            Range(Cells(Selection.Row, 2).Address).Select
            ActiveSheet.Paste
        Else
            Exit Sub
        End If
    End With
Next i
Application.ScreenUpdating = True

End Sub

Thanks in advance.

Regards,
PritishS

 

[Fluff]

How about

Sub PritishS()
    Dim Rng As Range
    With Range("B1", Range("B" & Rows.Count).End(xlUp))
        .Replace "PEN COLOR", True, xlPart, , True, , False, False
       For Each Rng In .SpecialCells(xlConstants, xlLogical).Areas
            Rng.Value = Rng.Offset(, 1).Value
        Next Rng
    End With
End Sub

 

[PritishS]

How about

Sub PritishS()
    Dim Rng As Range
    With Range("B1", Range("B" & Rows.Count).End(xlUp))
        .Replace "PEN COLOR", True, xlPart, , True, , False, False
       For Each Rng In .SpecialCells(xlConstants, xlLogical).Areas
            Rng.Value = Rng.Offset(, 1).Value
        Next Rng
    End With
End Sub

Hi Fluff

Thanks for your code. Let me try the same and get back to you soon.

 

[Fluff]

Just realised I forgot to clear the cell in col C. To do that use

Sub PritishS()
    Dim Rng As Range
    With Range("B1", Range("B" & Rows.Count).End(xlUp))
        .Replace "PEN COLOR", True, xlPart, , True, , False, False
       For Each Rng In .SpecialCells(xlConstants, xlLogical).Areas
            Rng.Value = Rng.Offset(, 1).Value
            Rng.Offset(, 1).Value = ""
        Next Rng
    End With
End Sub

 

[PritishS]

Just realised I forgot to clear the cell in col C. To do that use

Sub PritishS()
    Dim Rng As Range
    With Range("B1", Range("B" & Rows.Count).End(xlUp))
        .Replace "PEN COLOR", True, xlPart, , True, , False, False
       For Each Rng In .SpecialCells(xlConstants, xlLogical).Areas
            Rng.Value = Rng.Offset(, 1).Value
            Rng.Offset(, 1).Value = ""
        Next Rng
    End With
End Sub

Hi,
I figured that out.
I used

Rng.Offset(, 1).ClearContents

Your code is superb. I'm trying to modify my other code with reference to your code. I'll post the update accordingly. Thanks for getting back.

 

[Fluff]

You're welcome & thanks for the feedback

 

[PritishS]

You're welcome & thanks for the feedback

Hi,
Actually I posted the other code as example ( Though your solution worked great). Im looking for "which search for a specific text 'PEN COLOR' in column 2, select that cell and 1 cell to right, then cut the selection and paste 1 cell right to the same row", where some cut paste is involved. For that my code is

Sub Move_Pen_Name()
    Dim ws As Worksheet
    Dim aCell As Range
    Dim i As Long
Application.ScreenUpdating = False
    Set ws = ActiveSheet
For i = 1 To Rows.Count
    With ws
        Set aCell = .Columns(4).Find(What:="PEN COLOR", LookIn:=xlValues, _
                    LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                    MatchCase:=True, SearchFormat:=False)
        If Not aCell Is Nothing Then
            'aCell.Value = "Test"
            aCell.Select
            ActiveCell.Resize(1, 2).Cut
            Range(Cells(Selection.Row, 5).Address).Select
            ActiveSheet.Paste
        Else
            Exit Sub
        End If
    End With
Next i
Application.ScreenUpdating = True

End Sub

Any betterment (faster code) for this possible?

 

[Fluff]

Will "PEN COLOR" be on it's own in the cell, or part of a larger phrase?

 

[PritishS]

Will "PEN COLOR" be on it's own in the cell, or part of a larger phrase?

"PEN COLOR" will be the exact text. Not a part of any larger phrase.
.

Like this. My goal is to find 'PEN COLOR' in D column. Cut that cell and one cell next to it. then paste it to F column of same row. like that way code will search all 'PEN COLOR" in D column and do the same operation till last.

 

[Fluff]

Your code is pasting into col E, not F. Which is correct?