Selecting cells greater than date in a1

[mrtim2232]

Hi all,

I have got a macro that should select any cells within column C with a date value greater than the value I have entered into A1 I have ran the program and it doesn't cause any faults however It isn't selecting anything I'm sure my mistake is obvious any help would be appreciated the code is below:

Sub SelectByCellValue()
Dim lastrow As Long
Dim xRg As Range, yRg As Range
With ThisWorkbook.Worksheets("Sheet2")
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.ScreenUpdating = False
For Each xRg In .Range("C1:C" & lastrow)
'a1 contains a date value
If Range("a1").FormulaR1C1 = "=IF(RC[-3]<RC[-1],1,0)" Then
If yRg Is Nothing Then
Set yRg = .Range("A" & xRg.Row).Resize(, 2)
Else
Set yRg = Union(yRg, .Range("A" & xRg.Row).Resize(, 2))
End If
End If
Next xRg
Application.ScreenUpdating = True
End With

If Not yRg Is Nothing Then yRg.Select
End Sub

 

[wideboydixon]

Not sure what this line is intended to do:

If Range("a1").FormulaR1C1 = "=IF(RC[-3]<RC[-1],1,0)" Then

Suspect it should look more like this:

If xRg.Value > Range("a1").Value Then

WBD

 

[mrtim2232]

Thankyou It works like a charm If possible I'd like to be able to copy and paste the value in A1 to the newly selected cells the way I'm doing it now you have to re-run the macro for each cell which can be time consuming is there any way to get it to loop through and do all of the cells in the selection in one go? The code is below:

Sub SelectByCellValue()
Sheets("sheet2").Range("A1").Copy
Dim lastrow As Long
Dim xRg As Range, yRg As Range
With ThisWorkbook.Worksheets("Sheet2")
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
Application.ScreenUpdating = False
For Each xRg In .Range("C1:C" & lastrow)
'a1 contains a date value
If xRg.Value > Range("a1").Value Then
If yRg Is Nothing Then
Set yRg = .Range("C" & xRg.Row)
Else
Set yRg = Union(yRg, .Range("c" & xRg.Row))
End If
End If
Next xRg
Application.ScreenUpdating = True
End With

If Not yRg Is Nothing Then yRg.Select
ActiveCell.PasteSpecial xlValues
End Sub

 

[mrtim2232]

I've managed to figure my way through it thankyou for all of your help in improving this.

 

[wideboydixon]

Please use code tags next time. I suspect you want this:

Sub SelectByCellValue()


Dim lastRow As Long
Dim xRg As Range
Dim yRg As Range


Application.ScreenUpdating = False


With ThisWorkbook.Worksheets("Sheet2")
    lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
    For Each xRg In .Range("C1:C" & lastRow)
        'a1 contains a date value
        If xRg.Value > Range("A1").Value Then
            If yRg Is Nothing Then
                Set yRg = .Range("C" & xRg.Row)
            Else
                Set yRg = Union(yRg, .Range("C" & xRg.Row))
            End If
        End If
    Next xRg
    If Not yRg Is Nothing Then yRg.Value = .Range("A1").Value
End With


Application.ScreenUpdating = True


End Sub

WBD