Dec 232011
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 isRange(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
If you’re using the above, make sure you check/handle if there is more than one area in either the source or destination range.
Using the count property of
range.rows
orrange.columns
will only return the number of rows/columns in the first area of a range.I.e. using
rows.count
andcolumns.count
on the range “A1:A2,B1:B3” will return 2 and 1 respectively