Insert a table into word
 

Hi,

i have got the following code that takes infomation in the spreadsheet
and puts it into a word document. This includes a header and a table.
All the infomation goes into word OK until it puts in the table from
excel, It goes back to the top of the document and pastes over the top
of everything else. Does anyone have a solution to this problem?

Thanks



sub quote()

Application.DisplayAlerts = False

ActiveSheet.Unprotect

' Creates memos in word using Automation (late binding)

Dim name As Range, project As Range, quotation As Range, quoteby
As Range, amount As Range
Dim quote As String
Dim SaveAsName As String

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim rngDoc As Word.Range
Dim data As Range
Dim wdSelect As Word.Selection





Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open("H:\Administration\quote.dot ")
wrdApp.Visible = True
Set wdSelect = wrdDoc.ActiveWindow.Selection
Set rngDoc = wrdDoc.Content



' Information from worksheet
Set name = Sheets("quote").Range("b3")
Set project = Sheets("quote").Range("b4")
Set quoteby = Sheets("quote").Range("b6")
Set quotation = Sheets("quote").Range("b7")
Set amount = Sheets("quote").Range("G5")


' Determine the file name
SaveAsName = quotation & ".doc"

ChDrive ("H:\")
ChDir "H:\Administration"
Workbooks.Open FileName:="H:\Administration\quotes.xls"


Columns("A:A").Select
Selection.Find(What:=quotation, After:=ActiveCell,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate

ActiveCell.Offset(0, 6).Select
ActiveCell.Value = Date


ActiveCell.Offset(0, 1).Select
ActiveCell.Value = amount
ActiveWorkbook.Save
ActiveWorkbook.Close


quote = Sheets("quote").Range("a9",
Sheets("quote").Range("g65536").End(xlUp)).Address
Range(quote).Copy





With wrdDoc



.Bookmarks("header").Range.InsertAfter (project)





With rngDoc
.Font.name = "Times New Roman"
.Font.Size = 10
.Font.Bold = True
.Font.Italic = False
.ParagraphFormat.Alignment = 1
.Text = "QUOTATION"

.Font.name = "Times New Roman"
.Font.Size = 10
.Font.Bold = False
.Font.Italic = False
.ParagraphFormat.Alignment = 0

End With


.Content.PasteExcelTable True, True, True
.Content.InsertParagraphBefore
.Content.InsertBefore "QUOTATION"
.Content.InsertBefore "Here is a example test line #" & i
.Content.InsertParagraphBefore
.Content.InsertParagraphBefore
.Content.InsertParagraphBefore
.Content.InsertParagraphBefore
.Content.InsertParagraphBefore


.Content.InsertAfter "To:" & vbTab & name
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Date:" & vbTab & _
Format(Date, "mmmm d, yyyy")
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Project:" & vbTab & project
.Content.InsertParagraphAfter
.Content.InsertAfter "Our quotation reference " & quotation & ",
please quote on any correspondence"
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Further to your recent enquiry, we are
pleased to submit our budget quotation for the supply only fixed by
others of the following,"
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter













.Content.InsertAfter "Grand Total:" & " " & Format(amount,
"£#,##0.00")




.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter

.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Please note the following, "
.Content.InsertAfter "Any welding may show signs of distortion/
discoloration after the welding process."
.Content.InsertParagraphAfter
.Content.InsertAfter "Should you place an order we will need to be
advised where the finishers may jig."
.Content.InsertParagraphAfter
.Content.InsertAfter "These parts include top hat section, joint
straps and stiffening sections."
.Content.InsertParagraphAfter
.Content.InsertAfter "If successful with the above quote we
suggest that you contact our production manager Mr Peter Marano to
mutually agree a delivery period."
.Content.InsertParagraphAfter
.Content.InsertAfter "VAT to be added and charged at the current
rates."
.Content.InsertParagraphAfter
.Content.InsertAfter "Only items specifically itemised have been
allowed for."
.Content.InsertParagraphAfter
.Content.InsertAfter "Price includes for delivery within 100 miles
of St. Albans, Herts, should you wish us to deliver outside this area
then this will be charged extra to the above stated price."
.Content.InsertParagraphAfter
.Content.InsertAfter "If tolerances are critical then please
contact us to discuss your requirements."
.Content.InsertParagraphAfter
.Content.InsertAfter "Price subject to receiving full order and
hard copy working drawings."
.Content.InsertParagraphAfter
.Content.InsertAfter "Settlement terms strictly 30 days from date
of invoice and subject to continued acceptance by our trade insurers."
.Content.InsertParagraphAfter
.Content.InsertAfter "Any order that results from this quote will
be subject to our terms and conditions on the following page."
.Content.InsertParagraphAfter
.Content.InsertAfter "We look forward to receiving your further
instruction."
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Yours faithfully,"
.Content.InsertParagraphAfter



.SaveAs ("H:\Administration\") & (SaveAsName)


'.ActiveDocument.SaveAs FileName:=SaveAsName

End With


wrdApp.Quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing



MsgBox Records & " Quotation was created and saved in " & "H:
\Administration\" & "\" & SaveAsName

Application.DisplayAlerts = True
Sheets("hide").Visible = False
Sheets("rate table").Visible = False

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowFiltering:=True
Application.CutCopyMode = False

ActiveWorkbook.Save
Unload Me
ActiveWorkbook.Close


End Sub

Insert a table into word
 

Hi Oggy,

without studying all of your code,
if you use PasteExcelTable with a document's content
then all of the document is replaced by the Excel-table.
Don't use content,
but define a range, which represents a part of the doc,
where the table should go.

By the way, opening a template is usefull only
if you want to change the template.
Otherwise create a new document based on that template.

And post only the relevant parts of your code.
Yes, easier said than done.

HTH

--
Greetings from Bavaria, Germany

Helmut Weber, MVP WordVBA

Win XP, Office 2003
"red.sys" & Chr$(64) & "t-online.de"




Hi,

i have got the following code that takes infomation in the spreadsheet
and puts it into a word document. This includes a header and a table.
All the infomation goes into word OK until it puts in the table from
excel, It goes back to the top of the document and pastes over the top
of everything else. Does anyone have a solution to this problem?

Thanks



sub quote()

Application.DisplayAlerts = False

ActiveSheet.Unprotect

' Creates memos in word using Automation (late binding)

Dim name As Range, project As Range, quotation As Range, quoteby
As Range, amount As Range
Dim quote As String
Dim SaveAsName As String

Dim wrdApp As Word.Application
Dim wrdDoc As Word.Document
Dim rngDoc As Word.Range
Dim data As Range
Dim wdSelect As Word.Selection





Set wrdApp = CreateObject("Word.Application")
Set wrdDoc = wrdApp.Documents.Open("H:\Administration\quote.dot ")
wrdApp.Visible = True
Set wdSelect = wrdDoc.ActiveWindow.Selection
Set rngDoc = wrdDoc.Content



' Information from worksheet
Set name = Sheets("quote").Range("b3")
Set project = Sheets("quote").Range("b4")
Set quoteby = Sheets("quote").Range("b6")
Set quotation = Sheets("quote").Range("b7")
Set amount = Sheets("quote").Range("G5")


' Determine the file name
SaveAsName = quotation & ".doc"

ChDrive ("H:\")
ChDir "H:\Administration"
Workbooks.Open FileName:="H:\Administration\quotes.xls"


Columns("A:A").Select
Selection.Find(What:=quotation, After:=ActiveCell,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False).Activate

ActiveCell.Offset(0, 6).Select
ActiveCell.Value = Date


ActiveCell.Offset(0, 1).Select
ActiveCell.Value = amount
ActiveWorkbook.Save
ActiveWorkbook.Close


quote = Sheets("quote").Range("a9",
Sheets("quote").Range("g65536").End(xlUp)).Addres s
Range(quote).Copy





With wrdDoc



.Bookmarks("header").Range.InsertAfter (project)





With rngDoc
.Font.name = "Times New Roman"
.Font.Size = 10
.Font.Bold = True
.Font.Italic = False
.ParagraphFormat.Alignment = 1
.Text = "QUOTATION"

.Font.name = "Times New Roman"
.Font.Size = 10
.Font.Bold = False
.Font.Italic = False
.ParagraphFormat.Alignment = 0

End With


.Content.PasteExcelTable True, True, True
.Content.InsertParagraphBefore
.Content.InsertBefore "QUOTATION"
.Content.InsertBefore "Here is a example test line #" & i
.Content.InsertParagraphBefore
.Content.InsertParagraphBefore
.Content.InsertParagraphBefore
.Content.InsertParagraphBefore
.Content.InsertParagraphBefore


.Content.InsertAfter "To:" & vbTab & name
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Date:" & vbTab & _
Format(Date, "mmmm d, yyyy")
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Project:" & vbTab & project
.Content.InsertParagraphAfter
.Content.InsertAfter "Our quotation reference " & quotation & ",
please quote on any correspondence"
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Further to your recent enquiry, we are
pleased to submit our budget quotation for the supply only fixed by
others of the following,"
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter













.Content.InsertAfter "Grand Total:" & " " & Format(amount,
"£#,##0.00")




.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter

.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Please note the following, "
.Content.InsertAfter "Any welding may show signs of distortion/
discoloration after the welding process."
.Content.InsertParagraphAfter
.Content.InsertAfter "Should you place an order we will need to be
advised where the finishers may jig."
.Content.InsertParagraphAfter
.Content.InsertAfter "These parts include top hat section, joint
straps and stiffening sections."
.Content.InsertParagraphAfter
.Content.InsertAfter "If successful with the above quote we
suggest that you contact our production manager Mr Peter Marano to
mutually agree a delivery period."
.Content.InsertParagraphAfter
.Content.InsertAfter "VAT to be added and charged at the current
rates."
.Content.InsertParagraphAfter
.Content.InsertAfter "Only items specifically itemised have been
allowed for."
.Content.InsertParagraphAfter
.Content.InsertAfter "Price includes for delivery within 100 miles
of St. Albans, Herts, should you wish us to deliver outside this area
then this will be charged extra to the above stated price."
.Content.InsertParagraphAfter
.Content.InsertAfter "If tolerances are critical then please
contact us to discuss your requirements."
.Content.InsertParagraphAfter
.Content.InsertAfter "Price subject to receiving full order and
hard copy working drawings."
.Content.InsertParagraphAfter
.Content.InsertAfter "Settlement terms strictly 30 days from date
of invoice and subject to continued acceptance by our trade insurers."
.Content.InsertParagraphAfter
.Content.InsertAfter "Any order that results from this quote will
be subject to our terms and conditions on the following page."
.Content.InsertParagraphAfter
.Content.InsertAfter "We look forward to receiving your further
instruction."
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Yours faithfully,"
.Content.InsertParagraphAfter



.SaveAs ("H:\Administration\") & (SaveAsName)


'.ActiveDocument.SaveAs FileName:=SaveAsName

End With


wrdApp.Quit ' close the Word application
Set wrdDoc = Nothing
Set wrdApp = Nothing



MsgBox Records & " Quotation was created and saved in " & "H:
\Administration\" & "\" & SaveAsName

Application.DisplayAlerts = True
Sheets("hide").Visible = False
Sheets("rate table").Visible = False

ActiveSheet.Protect DrawingObjects:=True, Contents:=True,
Scenarios:=True _
, AllowFormattingCells:=True, AllowFormattingColumns:=True, _
AllowFormattingRows:=True, AllowFiltering:=True
Application.CutCopyMode = False

ActiveWorkbook.Save
Unload Me
ActiveWorkbook.Close


End Sub