Copy column and paste formulas only - not values - vba

Question

I'm trying to copy a column to the right of table and paste the formulas only (not values).
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
But this is copying also the values (because Excel considers values to be a formula too).
How do I fix this?

Answer 1

The below should fix your immediate problem of only copying the formulas across and not the values, but I'm not sure exactly what you're trying to do. If you can give more information I'm sure I can help you acheive what you're trying to get to.
It seems as if you want to copy the formulae to every row to the right of column D to the very right edge of the worksheet?
It also seems like you want to copy the formulae only so they re-evaluate in their new location - or do you want to past values only so that they hold the same values that they evaluated to in column D?
Anyway, give this a whirl.
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

As per my comments earlier:
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

Answer 3

When you say paste the formula only - your method will paste the formula and then recalculate and your formula will show the result. I think a better way to write that would be:
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
If you want to show the actual formula you could use a UDF something like:
Function GetFormula(Target As Range) As String
If Target.HasFormula Then
GetFormula = Target.Formula
End If
End Function
If you want to apply this to a whole column you could use:
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
This will probably kill your spreadsheet though - it will execute the UDF on all rows.

Answer 4

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