I though this would be trivial; turns out it’s not.
- When you copy a formula from the clipboard, relative references are adjusted, so
Range(x).Formula=Range(y).Formula doesn’t produce the expected results.
The correct way is Range(x).Formula=Range(y).FormulaR1C1. Easy once you’ve been there.
- Copying border formats with
Range(x).Borders=Range(y).Borders crashes Excel. You have to copy each individual border, left, right, top, etc.
- Similarly for fonts, you have to copy the font attributes one by one.
- Good practice: check that the areas have compatible sizes and don’t overlap.
Nothing inordinately difficult, but time-consuming to get right. Here’s the code:
Option Explicit
' Copy cells without using the clipboard.
'
' Source is a range from which to copy values/formulas/formats.
' Dest is the destination range. Must be either
' a single cell, the top-left of the target range. The source size (rows x columns) is copied.
' or
' a range exactly the same size as source. We throw an error if the shapes don't match.
'
' If 'what' is omitted, copies the values.
' what=CopyFormulas copies the formulas instead of the values.
' what=CopyFormats copies the formats.
' what=CopyFormulas+CopyFormats copies both.
'
' Examples:
' CopyCells Range("b2:c6"), Range("h10") ' Copies 8 cells (6x2) from B2 to H10
' CopyCells Range(cells(2,2),cells(6,3)), Range("h10") ' Idem
' CopyCells Range(cells(2,2),cells(6,3)), Range(cells(10,10),cells(14,12)) ' Fails, source is 6x2, dest is 6x3
' CopyCells Range("b2:c6"), Range("b3") ' Fails, source and dest intersect
Public Const CopyFormulas = 1
Public Const CopyFormats = 2
Public Sub CopyCells(source As Range, dest As Range, Optional what As Long)
' Turn off screen updating, wastes (a lot of) time
Dim updating As Boolean
updating = Application.ScreenUpdating
Application.ScreenUpdating = False
If IsMissing(what) Then
what = 0
End If
Dim r As Long
Dim c As Long
' If destination is not a singe (r,c) top-left cell, ensure that the ranges are the same shape and size
If dest.Rows.Count > 1 Or dest.Columns.Count > 1 Then
If dest.Rows.Count <> source.Rows.Count Or _
dest.Columns.Count <> source.Columns.Count Then
Err.Raise 1000, "CopyCells", "Destination area " & dest.Rows.Count & "x" & dest.Columns.Count & _
" is not the same shape as the source area " & source.Rows.Count & "x" & source.Columns.Count
End If
End If
If Not (Intersect(source, dest) Is Nothing) Then
Err.Raise 1000, "CopyCells", "Source area " & Replace(source.Address, "$", "") & " " & source.Rows.Count & "x" & source.Columns.Count & _
" intersects destination area " & Replace(dest.Address, "$", "") & " " & dest.Rows.Count & "x" & dest.Columns.Count
End If
For r = 1 To source.Rows.Count
For c = 1 To source.Columns.Count
If what And CopyFormulas Then
dest.Cells(r, c).Formula = source.Cells(r, c).FormulaR1C1
Else
dest.Cells(r, c).Value = source.Cells(r, c).Value
End If
If what And CopyFormats Then
Dim b As Long
For b = xlEdgeLeft To xlInsideHorizontal
With source.Cells(r, c).Borders(b)
dest.Cells(r, c).Borders(b).Weight = .Weight ' You must do this *before* linestyle
dest.Cells(r, c).Borders(b).LineStyle = .LineStyle
dest.Cells(r, c).Borders(b).ColorIndex = .ColorIndex
dest.Cells(r, c).Borders(b).TintAndShade = .TintAndShade
End With
Next
dest.Cells(r, c).ColumnWidth = source.Cells(r, c).ColumnWidth
dest.Cells(r, c).Interior.Color = source.Cells(r, c).Interior.Color
dest.Cells(r, c).Interior.Pattern = source.Cells(r, c).Interior.Pattern
dest.Cells(r, c).HorizontalAlignment = source.Cells(r, c).HorizontalAlignment
dest.Cells(r, c).IndentLevel = source.Cells(r, c).IndentLevel
dest.Cells(r, c).NumberFormat = source.Cells(r, c).NumberFormat
dest.Cells(r, c).Orientation = source.Cells(r, c).Orientation
dest.Cells(r, c).RowHeight = source.Cells(r, c).RowHeight
dest.Cells(r, c).UseStandardHeight = source.Cells(r, c).UseStandardHeight
dest.Cells(r, c).UseStandardWidth = source.Cells(r, c).UseStandardWidth
dest.Cells(r, c).VerticalAlignment = source.Cells(r, c).VerticalAlignment
dest.Cells(r, c).WrapText = source.Cells(r, c).WrapText
With source.Cells(r, c).Font
dest.Cells(r, c).Font.Background = .Background
dest.Cells(r, c).Font.Bold = .Bold
dest.Cells(r, c).Font.Color = .Color
dest.Cells(r, c).Font.ColorIndex = .ColorIndex
dest.Cells(r, c).Font.FontStyle = .FontStyle
dest.Cells(r, c).Font.Italic = .Italic
dest.Cells(r, c).Font.Shadow = .Shadow
dest.Cells(r, c).Font.Size = .Size
dest.Cells(r, c).Font.Strikethrough = .Strikethrough
dest.Cells(r, c).Font.Subscript = .Subscript
dest.Cells(r, c).Font.Superscript = .Superscript
dest.Cells(r, c).Font.Underline = .Underline
End With
On Error GoTo 0
End If
Next
Next
Application.ScreenUpdating = updating
End Sub
Sub test()
CopyCells Range("b2:c6"), Range("h10"), CopyFormulas + CopyFormats
End Sub
