Question

我尝试将列复制到表格右侧并仅粘贴公式（而不是值）。

Sub acrescentaCols()
Dim oSheet As Worksheet

Set oSheet = Sheets("Sheet1")
oSheet.Columns("D:D").Select
    Selection.Copy
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
End Sub

但这也是复制值（因为Excel也将值视为公式）。

我该如何解决这个问题？

Answer 1

下面应该解决你只是复制公式而不是值的直接问题，但我不确定你到底想要做什么。如果您能提供更多信息，我相信我可以帮助您实现您想要达到的目标。

好像你想将公式复制到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 = True Then
        cell.Copy
        Range(cell.Address, Range(cell.Address).End(xlToRight)).PasteSpecial Paste:=xlPasteFormulas
    End If
Next cell

End Sub

Answer 2

当您说只粘贴公式时 - 您的方法将粘贴公式然后重新计算，您的公式将显示结果。我认为更好的写作方式是：

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。

Answer 3

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

Answer 4

根据我之前的评论：

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

仅复制列和粘贴公式 - 而不是值

4 个答案: