下面应该解决你的直接问题，只复制公式，而不是值，但我不知道你到底想做什么。如果你能给予更多的信息，我相信我能帮助你达到你想要的目的。
看起来好像你想把公式复制到工作表最右边D列右边的每一行。
看起来您似乎只想复制公式，以便它们在新位置重新求值-或者您只想粘贴值，以便它们保持与列D中的求值值相同的值？
不管怎样，给予这个。

Sub acrescentaCols()
Dim oSheet As Worksheet

Set oSheet = Sheets("Sheet1")

For Each cell In oSheet.Range("D1", Range("D1").End(xlDown))
    If cell.HasFormula Then
        cell.Copy
        Range(cell, cell.End(xlToRight)).PasteSpecial Paste:=xlPasteFormulas
    End If
Next cell

End Sub

正如我之前的评论：

Sub acrescentaCols()
Dim oSheet As Worksheet
Dim rng As Range
Dim cel As Range
Set oSheet = Sheets("Sheet1")
With oSheet
    Set rng = .Range(.Range("D1"), .Range("D" & .Rows.Count).End(xlUp))
    For Each cel In rng
        If Left(cel.Formula, 1) = "=" Then
            Range(cel.Offset(, 1), cel.Offset(, 1).End(xlToRight)).Formular1c1 = cel.Formular1c1
        End If
    Next cel
End With
End Sub

当您说仅粘贴公式时-您的方法将粘贴公式，然后重新计算，您的公式将显示结果。我觉得更好的写法应该是：

Sub acrescentaCols()

    Dim oSheet As Worksheet
    Dim rCopied As Range

    Set oSheet = Sheets("Sheet1")

    With oSheet
        .Columns("D:D").Copy

        Set rCopied = .Cells(1, 4).End(xlToRight).Offset(, 1).EntireColumn
        rCopied.PasteSpecial Paste:=xlPasteFormulas

    End With

End Sub

如果你想显示实际的公式，你可以使用一个UDF，比如：

Function GetFormula(Target As Range) As String
    If Target.HasFormula Then
        GetFormula = Target.Formula
    End If
End Function

如果你想把它应用到整个列，你可以用途：

Sub acrescentaCols1()

    Dim oSheet As Worksheet
    Dim rCopied As Range

    Set oSheet = Sheets("Sheet1")

    With oSheet
        Set rCopied = .Cells(1, 4).End(xlToRight).Offset(, 1).EntireColumn
        rCopied.FormulaR1C1 = "=GETFORMULA(RC4)"
    End With

End Sub

这可能会杀死你的电子表格，虽然-它将执行所有行的UDF。

Sub acrescentaCols()
    Dim oSheet As Worksheet, rng1 As Range, rng2 As Range, rng As Range

    Set oSheet = Sheets("Sheet1")
    Set rng1 = oSheet.Columns("D:D")
        Set rng1 = Intersect(rng1, rng1.Worksheet.UsedRange) 'for the used range only
    Set rng2 = Range(rng1, rng1.End(xlToRight))
    For i = 1 To rng1.Cells.Count 'for each row
        If Left(rng1(i, 1).Formula, 1) = "=" Then 'if it starts with an equal sign
            For j = 1 To rng2.Columns.Count 'then for each column in the copy
                rng2(i, j).FormulaR1C1 = rng1(i, 1).FormulaR1C1
            Next j
        End If
    Next i
End Sub