How to copy a range of cells, keeping the same format using VBA code?

[Tingle]

Hi All,

I am trying to copy a range of cells but keeping the same formatting.

So far I have this

Private Sub CommandButton1_Click()

Sheets("Output").Visible = True
Sheets("Output").Range("B6:E12").Copy
Sheets("Output").Visible = False
Application.ScreenUpdating = False
End Sub

Thanks

Jon

 

[sericom]

You just need to specify the destination, eg

Sheets("Output").Range("B6:E12").Copy [U]Sheets("Output").Range("B14")[/U]

 

[Tingle]

Thanks for your reply, however I am not looking to move the data within excel. Ideally the copied data will drop into a table within a word document. Is there anyway to standardise the copying?

 

[Yongle]

Ideally the copied data will drop into a table within a word document

why omit such vital detail from your request?

Code to get you started
- tested with Excel 2016
- click on link for original code by SpreadsheetGuru.com
- the code is very lightly modified

To test
- create a new workbook
- put some dummy data in a range starting at cell A1
- paste the attached into a standard module
- add a reference to Microsoft Word Object Library (Tools \ References \ scoll down to Microsoft Word Object Library \ check the box \ click OK )
- run the code
- Word is opened and a new document created with the values formatted as in Excel
- modify to suit your specific needs after testing

Sub ExcelRangeToWord()

'PURPOSE: Copy/Paste An Excel Table Into a New Word Document
'NOTE: Must have Word Object Library Active in Order to Run  (VBE > Tools > References > Microsoft Word Object Library)
'SOURCE: www.TheSpreadsheetGuru.com

Dim tbl As Excel.Range
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim a As Integer
'Optimize Code
  Application.ScreenUpdating = False
  Application.EnableEvents = False

'Copy Range from Excel
                [I][COLOR=#696969]'ORIGINAL CODE Set tbl = ThisWorkbook.Worksheets(Sheet1.Name).ListObjects("Table1").Range[/COLOR][/I]
    Set tbl = ActiveSheet.Range("A1").CurrentRegion
'Create an Instance of MS Word
  On Error Resume Next
    
    'Is MS Word already opened?
      Set WordApp = GetObject(class:="Word.Application")
    
    'Clear the error between errors
      Err.Clear

    'If MS Word is not already open then open MS Word
      If WordApp Is Nothing Then Set WordApp = CreateObject(class:="Word.Application")
    
    'Handle if the Word Application is not found
      If Err.Number = 429 Then
        MsgBox "Microsoft Word could not be found, aborting."
        GoTo EndRoutine
      End If

  On Error GoTo 0
  
'Make MS Word Visible and Active
  WordApp.Visible = True
  WordApp.Activate
    
'Create a New Document
  Set myDoc = WordApp.Documents.Add
  
'Copy Excel Table Range
  tbl.Copy

'Paste Table into MS Word
  myDoc.Paragraphs(1).Range.PasteExcelTable _
    LinkedToExcel:=False, _
    WordFormatting:=False, _
    RTF:=False

'Autofit Table so it fits inside Word Document
  Set WordTable = myDoc.Tables(1)
               [I][COLOR=#696969] 'REMOVED AUTOFIT AND MATCHED EXCEL INSTEAD WordTable.AutoFitBehavior (wdAutoFitWindow)[/COLOR][/I]
    For a = 1 To tbl.Columns.Count
        WordTable.Columns(a).Width = tbl.Columns(a).Width
    Next a
EndRoutine:
'Optimize Code
  Application.ScreenUpdating = True
  Application.EnableEvents = True

'Clear The Clipboard
  Application.CutCopyMode = False

End Sub