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

 

[PritishS]

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

E column. I want to move those D,E to E,F. Sorry for the Mistake!!

 

[Fluff]

Ok, how about

Sub PritishS()
    Dim rng As Range
    With Range("D1", Range("D" & Rows.Count).End(xlUp))
        .Replace "PEN COLOR", True, xlWhole, , True, , False, False
       For Each rng In .SpecialCells(xlConstants, xlLogical).Areas
            rng.Offset(, 1).Resize(, 2).Value = rng.Resize(, 2).Value
            rng.ClearContents
        Next rng
        .Offset(, 1).Replace True, "PEN COLOR", xlWhole, , True, , False, False
    End With
End Sub

 

[PritishS]

Ok, how about

Sub PritishS()
    Dim rng As Range
    With Range("D1", Range("D" & Rows.Count).End(xlUp))
        .Replace "PEN COLOR", True, xlWhole, , True, , False, False
       For Each rng In .SpecialCells(xlConstants, xlLogical).Areas
            rng.Offset(, 1).Resize(, 2).Value = rng.Resize(, 2).Value
            rng.ClearContents
        Next rng
        .Offset(, 1).Replace True, "PEN COLOR", xlWhole, , True, , False, False
    End With
End Sub

Thanks, let me check and update you.

 

[PritishS]

Ok, how about

Sub PritishS()
    Dim rng As Range
    With Range("D1", Range("D" & Rows.Count).End(xlUp))
        .Replace "PEN COLOR", True, xlWhole, , True, , False, False
       For Each rng In .SpecialCells(xlConstants, xlLogical).Areas
            rng.Offset(, 1).Resize(, 2).Value = rng.Resize(, 2).Value
            rng.ClearContents
        Next rng
        .Offset(, 1).Replace True, "PEN COLOR", xlWhole, , True, , False, False
    End With
End Sub

Perfect!!! You are great Sir!! . Just one small thing. I want to keep the same color/format. It's now 'PEN COLOR' is in same cell color of 'RED' and cell for 'RED' is now colorless and font change to normal (where it was BOLD) and black ( where is was RED).
Can I keep same as it was?

 

[Fluff]

Just use

            rng.Resize(, 2).Copy rng.Offset(, 1)

Also you don't need to quote whole posts, just use the quick reply window at the bottom of the thread.

 

[PritishS]

THANK YOU VERY MUCH!! This is flawless!!
Before your great code my code was taking too much time ( about 215 sec.) to complete the task (around 6000 rows are there).
Now its taking only '62 sec.' to complete the same task! It's so great!
Somehow 'Quick Reply' button is not visible here. I'll keep it in mind!
Once again Thank you very much for spearing valuable time for me! Wish you a Merry Christmas!!

Thanks & Regrads
PritishS

 

[Fluff]

You're welcome & thanks for the feedback.

Somehow 'Quick Reply' button is not visible here. I'll keep it in mind!

It's not a button its the window at the bottom of the thread, like

Although you will see it with your avatar, rather than mine.

 

[PritishS]

Thank you Sir!! Have a good day!!