复制大于零的单元格，并将值粘贴到同一单元格中

Question

我有一张表格，里面填满了与另一张表格相关联的公式。这些公式根据列顶部的日期是否与单个单元格中的日期（周结束日期）相匹配，从另一个表中获取数据。我希望能够仅自动复制值大于 0 的单元格，然后将它们作为值粘贴回同一个单元格中。我使用以下公式来尝试完成此操作，但它并没有完全达到我想要的效果。温柔点，我充其量是个新手。

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

预期输出：仅复制表格中大于 0 的单元格并粘贴为值。

目标：在空白单元格中保留公式

上面的结果：逐个单元格的进度非常缓慢，并复制并粘贴到所有单元格中，包括空白和 0 值，直到它停止

Answer 1

试试这个：

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

编辑：添加一个使用数组循环数据的替代方案，这应该会快一点：

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