A better way to do this kind of loop?

[JumboCactuar]

Range("a2:a1000").Select
    For Each r In Selection
        If r.Value >0 Then
            r.Offset(0, 3) = Now()
        End If
    Next r

I know theres probably a way without selecting, these sometimes run slow when making changes to a lot of cells

 

[Michael M]

try

Sub MM1()
Dim r As Range
Application.ScreenUpdating = False
For Each r In Range("a2:a1000")
        If r.Value > 0 Then r.Offset(0, 3) = Now()
    Next r
Application.ScreenUpdating = True
End Sub

 

[MARK858]

Personally I wouldn't use a loop, one other way....

Sub FilterGreaterThanOne()
    With Range("a1:a1000")
        .AutoFilter Field:=1, Criteria1:=">0", Operator:=xlAnd, Criteria2:="<>"

        On Error Resume Next
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Offset(, 3) = Now
        On Error GoTo 0
        .AutoFilter

    End With
End Sub

 

[JumboCactuar]

try

Sub MM1()
Dim r As Range
Application.ScreenUpdating = False
For Each r In Range("a2:a1000")
        If r.Value > 0 Then r.Offset(0, 3) = Now()
    Next r
Application.ScreenUpdating = True
End Sub

thanks, modified slightly and its much quicker

Sub test1()Dim r As Range
Dim l
Dim lastrow As Long
Application.ScreenUpdating = False


lastrow = Range("A" & Rows.Count).End(xlUp).Row


For Each r In Range("a2:a" & lastrow)
        If r.Value > 0 Then r.Offset(0, 1) = Now()
    Next r
    
Application.ScreenUpdating = True


End Sub

 

[JumboCactuar]

Personally I wouldn't use a loop, one other way....

Sub FilterGreaterThanOne()
    With Range("a1:a1000")
        .AutoFilter Field:=1, Criteria1:=">0", Operator:=xlAnd, Criteria2:="<>"

        On Error Resume Next
        .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Offset(, 3) = Now
        On Error GoTo 0
        .AutoFilter

    End With
End Sub

never thought about using filter, this is great and even with test data of 100,000 rows its almost instant
the loop with 100k rows freezes excel up for a few seconds

thanks

 

[MARK858]

You are welcome, you might get a saving by turning off screenupdating but I doubt if it will be enough to notice it.

 

[Jaafar Tribak]

Range("a2:a1000").Select
    For Each r In Selection
        If r.Value >0 Then
            r.Offset(0, 3) = Now()
        End If
    Next r

I know theres probably a way without selecting, these sometimes run slow when making changes to a lot of cells

Another fast way :

Sub Test()
    Dim oSelection As Range

    Application.ScreenUpdating = False
    Set oSelection = Selection
    With Range("D2:D1000")
        .FormulaArray = "=IF(A2:A1000>0,NOW(),"""")"
        .Copy: .PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False: oSelection.Select
    End With
End Sub

 

[Fluff]

Another option

Sub AddNow()
   With Range("D2", Range("A" & Rows.Count).End(xlUp).Offset(, 3))
      .Value = Evaluate(Replace(Replace("if(@a>0,now(),@)", "@a", .Offset(, -3).Address), "@", .Address))
   End With
End Sub

 

[JumboCactuar]

Another option

Sub AddNow()
   With Range("D2", Range("A" & Rows.Count).End(xlUp).Offset(, 3))
      .Value = Evaluate(Replace(Replace("if(@a>0,now(),@)", "@a", .Offset(, -3).Address), "@", .Address))
   End With
End Sub

Thanks Fluff this works great
Gonna need to learn how this works though to use in other circumstances, nice code