Ο χÏ�ήστης "Ayo" Î*γγÏ�αψε:

I am trying to do a Find and Replace in Range("A5:AK1757") and I have the
following code to do it but it is just taking too long, more than 30 minutes.
IS there a better way to do this faster?
Thanks

For Each progresshdr In rngProgresshdr.Cells
proPos = InStr(1, progresshdr.Address(ColumnAbsolute:=False), "$",
vbTextCompare)
progresslastColumn = Left(progresshdr.Address(ColumnAbsolute:=False),
proPos - 1)

If Right(progresshdr.Value, 4) = "Date" Then
ActiveSheet.Range(progresslastColumn & "5:" & progresslastColumn &
progresslastRow).Select
For Each c In Selection
If c.Value <= Date And c.Offset(0, 1).Value = "Projected" Then
c.Offset(0, 1).Value = "Past Due"
End If
Next
End If
Next progresshdr

This is an other way:

Option Explicit
Declare Function GetTickCount Lib "kernel32" () As Long

Sub FindAndReplace()
Dim rngFirstCol As Range
Dim rngCol As Range
Dim rngCell As Range
Dim lngRow As Long
Dim lngStart As Long

lngStart = GetTickCount
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

On Error Resume Next
Set rngFirstCol = Rows(5).Find("Status" _
, , , , xlByColumns).EntireColumn _
.SpecialCells(xlCellTypeConstants)
Set rngCol = rngFirstCol

If Not rngCol Is Nothing Then
Do
With rngCol
Set rngCell = .Find("Projected", , , , xlByRows)
If Not rngCell Is Nothing Then
Do
lngRow = rngCell.Row
If rngCell.Offset(, -1) <= Date Then
rngCell = "Past Due"
End If
Set rngCell = .FindNext(rngCell)
Loop While rngCell.Row lngRow
End If
End With
Set rngCol = Rows(5).Find("Status", rngCol(1) _
, , , xlByColumns).EntireColumn _
.SpecialCells(xlCellTypeConstants)
Loop While rngFirstCol.Column < rngCol.Column
End If

With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
Debug.Print GetTickCount - lngStart & " msec"
End Sub

Supposal:
"Status" is the caption of the header of all status columns.