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

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

1 个答案: