Is there a better code to do this?
 

Hi

You can turn off screenupdating and set calculation to manual, and finally
skip the select statement.

Sub aaa()
Dim TargetRange As Range
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
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
Set TargetRange = ActiveSheet.Range(ProgressLastColumn & "5:" &
ProgressLastColumn & progresslastRow)
For Each c In TargetRange
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
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Hopes this helps.

---
Per

"Ayo" skrev i meddelelsen
...
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