Is there a better code to do this?

[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

 

[Ayo]

I am working in Range("D5:AK1760") and in this range there are sets of 2
columns side by side, one with dates and the other with status. If the date
is less than or equal to today and the cell,c.Offset(0,1)="Projected", change
the cell, c.Offset(0,1), to Past Due. That is all I am trying to do. The
problem is that I have to do it for each column with the date header and
there are about 17 columns.

 

[Ayo]

Thanks Per. This works perfect; it took less than 30secs. Beautiful.

 

[joel]

LastRow = Range("D" & Rows.Count).End(xlUp).Row
LastColumn = Cells(5, Columns.Count).End(xlToLeft).Column

For ColCount = 7 To LastColumn Step 2
For RowCount = 5 To LastRow
Status = Cells(RowCount, ColCount)
MyDate = Cells(RowCount, ColCount - 1)
If Status = "Projected" And _
MyDate <= Date Then
Cells(RowCount, ColCount) = "PastDue"
End If
Next RowCount
Next ColCount

 

[John_John]

Ο χÏήστης "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.