CODEWITHSUNDEEP
excelvba
Duck9139
Duck9139

Reputation: 69

Copy Cells Greater than Zero, and Paste Values in same Cell

I have a table that is filled with formulas tied to another sheet. These formulas grab data from the other table based on whether the date at the top of the column matches the date in a single cell (Week Ending Date). I want to be able to automatically copy only the cells with a value greater than 0, and then paste them back into the same cell as a value. I used the following formula to try and accomplish this, but it didn't quite do what I wanted it to. Be gentle, I'm a novice at best.

Sub CopyC()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("Table4")
For Each cel In SrchRng
    If cel.Value > 0 Then
        cel.Copy
    cel.PasteSpecial xlPasteValues
    End If
Next cel
End Sub

Expected Output: Copy only Cells in my table that are greater than 0 and paste as value.

Goal: Preserve Formulas in cells that are blank

Results from above: Very slowly progressed cell by cell and copied and pasted in all cells, including blanks and 0 values, until it was stopped

Upvotes: 2

Views: 1487

Answers (1)

FAB
FAB

Reputation: 2569

Give this a try:

Sub CopyC()
Dim SrchRng As Range, cel As Range
Set SrchRng = Range("Table4")
For Each cel In SrchRng
    If IsNumeric(cel.Value) And cel.Value > 0 Then
        cel.Value = cel.Value
    End If
Next cel
End Sub

EDIT: add an alternative using an array to loop through the data, this should be a bit faster:

Sub CopyC()

Dim SrchRng As Range: Set SrchRng = Range("Table4")
Dim arrSearch As Variant: arrSearch = SrchRng

Dim fRow As Long: fRow = SrchRng.Cells(1, 1).Row - 1
Dim fCol As Long: fCol = SrchRng.Cells(1, 1).Column - 1
Dim R As Long, C As Long

For R = LBound(arrSearch) To UBound(arrSearch)
    For C = LBound(arrSearch, 2) To UBound(arrSearch, 2)
        If IsNumeric(arrSearch(R, C)) And arrSearch(R, C) > 0 Then Cells(R + fRow, C + fCol).Value = arrSearch(R, C)
    Next C
Next R
End Sub

Upvotes: 2

Related Questions