Скопируйте ячейки больше нуля и вставьте значения в одну ячейку

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