Instead of UsedRange, how do I copy the exact cell range from Excel to a Word document?
Sub export_excel_to_word()
Set obj = CreateObject("Word.Application")
obj.Visible = True
Set newObj = obj.Documents.Add
ActiveSheet.UsedRange.Copy
newObj.Range.Paste
Application.CutCopyMode = False
obj.Activate
newObj.SaveAs Filename:=Application.ActiveWorkbook.Path & "\" & ActiveSheet.Name
End Sub
This should be pretty easy to do. Just set a reference to word and run the script below. Of course, feel free to modify the script to suit your specific needs.
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 12.0 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
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Range from Excel
Set tbl = ThisWorkbook.Worksheets(1).Range("A1:J10")
'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)
WordTable.AutoFitBehavior (wdAutoFitWindow)
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Related
I've created a macro to paste an Excel table into word but the macro isn't working, and I can't figure out what I'm doing wrong. See code below for reference.
I've also checked the "Reference" --> "Microsoft Word 16.0 Object Library"
TIA!
'
' CreateLabels Macro
Dim objWord
Dim objDoc
Set objWord = CreateObject("Word.Application")
Set objDoc = objWord.Documents.Open("C:\Users\username\Desktop\New Template.doc")
Dim x As Workbook
'Open Excel and Copy labels
Set x = Workbooks.Open("Excel file path")
With x.Sheets("Receiving Labels")
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
End With
x.Sheets("Receiving Labels").Range("A1:E" & LastRow).Copy
With objDoc.Paragraphs(objDoc.Paragraphs.Count).Range
'All formatting goes here
.Paste
.Font.Name = "Calibri"
.Font.Color = wdColorBlack
.Font.Bold = False
.Font.Italic = False
.Font.Allcaps = False
.Font.Size = 8
End With
objWord.Visible = True
End Sub
Try this:
Sub ExcelToWord()
'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 12.0 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
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Range from Excel
Set tbl = ThisWorkbook.Worksheets(Sheet1.Name).ListObjects("Table1").Range
'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)
WordTable.AutoFitBehavior (wdAutoFitWindow)
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
In the same context to [https://stackoverflow.com/questions/66407797/having-problems-copying-an-excel-range-to-a-word-file-using-vba][1]
As I have been helped, I try to make a loop, as I have the same area on several sheets in a worksheet / book, which I would like to copy via a loop to an existing word document (sheet by sheet), save it as a PDF and move on to the next sheet.
I have tried the following, but get an error: "Run-Time error '462' - the remote server machine does not exist or is unavailable".
It's for the code line:
Set myDoc = WordApp.Documents.Open(Filename:=stWordDocument, AddToRecentFiles:=False, Visible:=False)
Code try "Updated code" from BigBen:
Sub CopyToWordAndPrintPDF()
'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 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com
'Name of the existing Word document
Const stWordDocument As String = "C:\Users\SDETHBP\Documents\FCM\FCM Ulvetræning Øvelser\U7-U12\Word Forside\Forside fra Excel test.docx"
'Word objects/declared variables.
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim Ws As Worksheet
Dim myArr As Variant, a As Variant
Dim rangeArr As Variant
Dim i As Integer
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'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
With WordApp
'Make MS Word Visible and Active
WordApp.Visible = False
'Create a loop
myArr = Array("U7AB1", "U7AB2", "U7BC1")
rangeArr = "A1:N24"
'Set myDoc = WordApp.Documents.Add
'Change: [Set myDoc = WordApp.Documents.Add] to:
Set myDoc = WordApp.Documents.Open(Filename:=stWordDocument, AddToRecentFiles:=False, Visible:=False)
For i = 0 To UBound(myArr)
Set Ws = Sheets(myArr(i))
With Ws
'Copy Excel content to word
ThisWorkbook.Worksheets(myArr(i)).Range(rangeArr).Copy
With Documents(stWordDocument).PageSetup
.LineNumbering.Active = False
.TopMargin = CentimetersToPoints(0)
.BottomMargin = CentimetersToPoints(0)
.LeftMargin = CentimetersToPoints(0)
.RightMargin = CentimetersToPoints(0)
'Paste it to the selected Word template
With myDoc
.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
.SaveAs2 Filename:=Split(stWordDocument, ".docx")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
'.SaveAs2 Filename:=ThisWorkbook.Name & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close False
End With
End With
End With
Next
.Quit
End With
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Can someone guide me?
so I can get a PDF per. sheet, where it takes the same area, on each sheet, but saves it as independent pdf files, preferably named after the sheet name.pdf.
From the same word file, which should not be saved as now, but will be used as it has a watermark, which should go again for all sheets.
[1]: Having problems copying an Excel range to a Word file using VBA
Just to wrap up what is in the comments above:
Sub CopyToWordAndPrintPDF()
'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 12.0 Object Library)
'SOURCE: www.TheSpreadsheetGuru.com
'filepath and word template
Const filePath As String = "C:\Users\SDETHBP\Documents\FCM\FCM Ulvetræning Øvelser\U7-U12\"
Const wordTemplate As String = "Word Forside\Forside fra Excel test.dotx"
'Word objects/declared variables.
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim Ws As Worksheet
Dim myArr As Variant, a As Variant
Dim rangeArr As Variant
Dim i As Integer
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'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
With WordApp
'Make MS Word Visible and Active
WordApp.Visible = False
'Create a loop
myArr = Array("U7AB1", "U7AB2", "U7BC1")
rangeArr = "A1:N24"
For i = 0 To UBound(myArr)
'Copy Excel content to word
ThisWorkbook.Worksheets(myArr(i)).Range(rangeArr).Copy
Set myDoc = WordApp.Documents.Add(Template:=filePath & wordTemplate, Visible:=False)
'With Documents(stWordDocument).PageSetup
With myDoc
With .PageSetup
.LineNumbering.Active = False
.TopMargin = CentimetersToPoints(0)
.BottomMargin = CentimetersToPoints(0)
.LeftMargin = CentimetersToPoints(0)
.RightMargin = CentimetersToPoints(0)
End With
'Paste it to the selected Word template
.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
.SaveAs2 Filename:=filePath & myArr(i) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close False
End With
Next
.Quit
End With
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
I have a an Excel workbook with that creates a table and exports the table to MS word. My client now wants to also insert a drop down list into the last column of the word table. I cannot find any material on this. Can it be done? I would like to create a combobox and insert it into each cell in the "Interpretation" column. Can someone point me in the right direction or supply some sample code?
Current code:
Sub ExportToWord()
Dim ws As Worksheet
Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim objRange As Word.Range
Dim bWeStartedWord As Boolean
Dim newDoc As Boolean, onSave As Boolean
Dim rng As Range
Dim lRow As Integer, s As Integer
If UF_Load.check_new = True Then
newDoc = True
Else
newDoc = False
End If
Set ws = ThisWorkbook.Sheets("UI")
On Error Resume Next
Set wrdApp = GetObject(, "Word.Application")
On Error GoTo 0
Application.ScreenUpdating = False
Application.EnableEvents = False
s = ws.Range("rng_demo").Row - 1
c = ws.Range("rng_demo").Column
lRow = ws.Cells(Rows.count, s).End(xlUp).Row
Set rng = ws.Range("A" & s).Resize(lRow, 8)
rng.Copy
If wrdApp Is Nothing Then
Set wrdApp = CreateObject("Word.Application")
bWeStartedWord = True
End If
'Handle if Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word document could not be found, aborting", vbExclamtion, "Microsoft Word Error 429"
GoTo SafeExit:
End If
On Error GoTo 0
'Make MS Word Visible and Active
wrdApp.Visible = True
wrdApp.Activate
'
wrdApp.Visible = True
If newDoc = True Then
Set wrdDoc = wrdApp.Documents.Add 'create as new word document
'Copy table data to word doc
Set tbl = rng 'ThisWorkbook.Sheets("UI").Range("A4:H25")
tbl.Copy
'Paste Table into Word doc
wrdDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit table to Word doc
Set wordtable = wrdDoc.Tables(1)
wordtable.AutoFitBehavior (wdAutoFitWindow)
Else
'or open an existing document
Set wrdDoc = wrdApp.Documents.Open(filepath) 'wrdApp.Documents.Open("C:\Users\Apache Paint\Desktop\Clients\Stephen Schmitz\TestDocument.docx")
'Copy table data to word doc
With wrdDoc
Set tbl1 = .Tables.Add(Range:=wrdDoc.Paragraphs.Last.Range, _
NumRows:=1, NumColumns:=8, _
AutoFitBehavior:=wdAutoFitWindow) 'autofit content 'DefaultTableBehavior:=wdWord9TableBehavior,
With tbl1
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
End With
Set tbl = rng 'ThisWorkbook.Sheets("UI").Range("A4:H25")
tbl.Copy
Set objRange = wrdDoc.Content
With objRange
.Collapse Direction:=0 'wdCollapseEnd
.InsertAfter vbCrLf
.Collapse Direction:=0
.InsertBreak Type:=wdPageBreak
.Paste '<< paste the table
End With
'Autofit the document
Set wordtable = objRange.Tables(1)
wordtable.AutoFitBehavior (wdAutoFitWindow)
With wordtable
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
End With
End With
filepath = ""
End If
SafeExit:
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.CutCopyMode = False
End Sub
I was able to get it to work with the code below. Thanks to those who suggested I look into ContentControl.
Now I am intermittently getting 'Run-time error 462. The remote server machine does not exist or is unavailable.'
I will update the cooment back here when it is fully resolved.
'Copy table data to word doc
Set tbl = rng 'ThisWorkbook.Sheets("UI").Range("A4:H25")
tbl.Copy
'Paste Table into Word doc
wrdDoc.Paragraphs(1).Range.PasteExcelTable _
LinkedToExcel:=False, _
WordFormatting:=False, _
RTF:=False
'Autofit table to Word doc
Set Wordtable = wrdDoc.Tables(1)
Wordtable.AutoFitBehavior (wdAutoFitWindow)
Dim oRow As Row
'Dim oRng As Range
'Loop through last table column and add Combobox
With Wordtable
For Each oRow In Wordtable.Rows
'Set oRng = oRow.Cells(1).Range
If Len(oRow.Cells(7).Range.Text) > 11 Then
Set objCC = ActiveDocument.ContentControls.Add(wdContentControlDropdownList, oRow.Cells(8).Range)
objCC.Title = "Interpretation"
If objCC.ShowingPlaceholderText Then
objCC.SetPlaceholderText , , "-Select-"
objCC.DropdownListEntries.Add "Far Below Expectaions"
objCC.DropdownListEntries.Add "Below Expectaions"
objCC.DropdownListEntries.Add "Slightly Below Expectaions"
objCC.DropdownListEntries.Add "Significant Difference"
objCC.DropdownListEntries.Add "Valid"
objCC.DropdownListEntries.Add "WNL"
Debug.Print Len(oRow.Cells(7).Range.Text)
End If
Else
End If
Next
End With
I am a total VBA novice, but I've managed to cobble together some code which allows me to export an excel 2010 chart into a new Word 2010 document. The only problem I have is that I would like to unlink the chart from excel once it is exported, so that it doesn't change when excel is updated. I've looked everywhere, but nothing seems to work.
The only other code which seems to fit the bill takes the chart and saves it as an image prior to pasting it, but this would not work as I have nowhere to save the image - users in our organisation do not have access to the C:\ drive, and without knowing everyone's user details, I cannot write code which will do the job.
The code I've written so far is this, which does work, but does not unlink:
Sub Copy_Paste_Report_1_Graph_to_new_word_document()
'
'Copy/Paste An Excel Chart Into a New Word Document
'(VBE > Tools > References > Microsoft Word 12.0 Object Library)
'Excel Objects
Dim ChartObj As ChartObject
'Word Objects
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
'Copy Chart from Excel
Set ChartObj = Worksheets("External Dashboard").ChartObjects("Chart 1")
'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 Chart
ChartObj.Copy
'Paste Chart into MS Word
myDoc.Paragraphs(1).Range.PasteSpecial Link:=False _
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
I've probably included more than I need to, but like I said, I'm a novice.
Use .CopyPicture and .PasteSpecial methods:
Sub Copy_Paste_Report_1_Graph_to_new_word_document()
Dim ChartObj As ChartObject
Dim WordApp As Word.Application
Dim myDoc As Word.Document
Set ChartObj = Worksheets("External Dashboard").ChartObjects("Chart 1")
Set WordApp = CreateObject(class:="Word.Application")
WordApp.Visible = True
WordApp.Activate
Set myDoc = WordApp.Documents.Add
ChartObj.CopyPicture xlScreen, xlPicture
myDoc.Paragraphs(1).Range.PasteSpecial
End Sub
I'm trying to copy a content from excel into a bookmark in MS word. But I'm getting run time error 424. Kindly help me with it. I'm very new to Visual basics and programming as well. I have attached my code.
Thanks
Sub WordDoc()
Dim wrdApp As Object
Dim Number As String
Dim wrdDoc As Object
Set wrdApp = CreateObject("Word.Application")
wrdApp.Visible = True
Set wrdDoc = wrdApp.Documents.Open("H:\IP Automation\createDoc.docx")
Number = Worksheets("Sheet1").Range("A2")
Call InsBookmark(ID, Number)
End Sub
Sub InsBookmark(strBMName, strVariable)
If strVariable <> "" Then
If ActiveDocument.Bookmarks.Exists(ID) Then
ActiveDocument.Bookmarks(ID).Select
Selection.Delete
Selection.InsertAfter (strVariable)
End If
End If
End Sub
You shouldn't seperate this into two subs, as the word doc will not persist across them so "ActiveDocument" wont work. just copy the code from the second sub into the first and replace ActiveDocument with wrdDoc
This should work for you. Give it a go and see how you get along.
Sub Export_Table_Word()
'Name of the existing Word doc.
Const stWordReport As String = "Final Report.docx"
'Word objects.
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdbmRange As Word.Range
'Excel objects.
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim rnReport As Range
'Initialize the Excel objects.
Set wbBook = ThisWorkbook
Set wsSheet = wbBook.Worksheets("PwC Contact Information")
Set rnReport = wsSheet.Range("Table1")
'Initialize the Word objets.
Set wdApp = New Word.Application
Set wdDoc = wdApp.Documents.Open(wbBook.Path & "\" & stWordReport)
Set wdbmRange = wdDoc.Bookmarks("Report").Range
Dim tbl As Table
For Each tbl In wdDoc.Tables
tbl.Delete
Next tbl
'If the macro has been run before, clean up any artifacts before trying to paste the table in again.
On Error Resume Next
With wdDoc.InlineShapes(1)
.Select
.Delete
End With
On Error GoTo 0
'Turn off screen updating.
Application.ScreenUpdating = False
'Copy the report to the clipboard.
rnReport.Copy
'Select the range defined by the "Report" bookmark and paste in the report from clipboard.
With wdbmRange
.Select
.Paste
End With
'Save and close the Word doc.
With wdDoc
.Save
.Close
End With
'Quit Word.
wdApp.Quit
'Null out your variables.
Set wdbmRange = Nothing
Set wdDoc = Nothing
Set wdApp = Nothing
'Clear out the clipboard, and turn screen updating back on.
With Application
.CutCopyMode = False
.ScreenUpdating = True
End With
MsgBox "The report has successfully been " & vbNewLine & _
"transferred to " & stWordReport, vbInformation
End Sub