sharky12345
Well-known Member
- Joined
- Aug 5, 2010
- Messages
- 3,388
- Office Version
- 2016
- Platform
- Windows
I'm using the following to copy charts and a small range to a Word Template but I am having a couple of issues.
The first one is that I get 'Type Mismatch' twice while it does the pasting and just before it saves the Word document.
The second is that the Charts are not pasting correctly - I have space for 4 but only want 2 Charts pasted, 1 on each page before the range is pasted.
Having space for 4 Charts causes them to be reduced in size when they are pasted. I'm no familiar enough with this code to know where the problem is if anyone can point me in the right direction please?
The first one is that I get 'Type Mismatch' twice while it does the pasting and just before it saves the Word document.
The second is that the Charts are not pasting correctly - I have space for 4 but only want 2 Charts pasted, 1 on each page before the range is pasted.
Having space for 4 Charts causes them to be reduced in size when they are pasted. I'm no familiar enough with this code to know where the problem is if anyone can point me in the right direction please?
Code:
Dim oWordDoc As Object, oWord As Object, nt%
Option Explicit
Sub E_W()
Dim strDate As String
Dim DirName As String
strDate = Format((Date), "ddmmyyyy")
PasteCharts
DataPaste
oWordDoc.SaveAs Filename:=ThisWorkbook.Path & "\Data Report - created " & strDate & ".doc", FileFormat:= _
wdFormatDocument, LockComments:=False
Set oWordDoc = Nothing
Set oWord = Nothing
End Sub
Sub PasteCharts()
Dim sFile$, i%, j%, counter%, mt As Table, wr As Word.Range
Dim tablen%, nc%, LinNum%, au%
sFile = ThisWorkbook.Path & "\Template.dot"
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
If Err <> 0 Then Set oWord = CreateObject("Word.Application")
Err.Clear
On Error GoTo Err_Handler
nc = Sheets("Charts").ChartObjects.Count
Set oWordDoc = oWord.Documents.Open(sFile)
oWord.Visible = True
oWordDoc.Activate
If oWordDoc.Tables.Count > 0 Then
Do
au = oWordDoc.Tables.Count
oWordDoc.Tables(au).Delete
Loop Until au = 1
End If
If nc Mod 1 = 0 Then
nt = nc / 1 ' how many tables are needed
Else ' four charts per page
nt = (nc \ 1) + 1
End If
oWord.Selection.EndKey Unit:=wdStory
Set wr = oWord.Selection.Range
LinNum = wr.Information(wdFirstCharacterLineNumber)
If LinNum > 2 Then
Do ' eliminate extra lines at the beginning
wr.Delete
LinNum = wr.Information(wdFirstCharacterLineNumber)
Loop Until LinNum = 2
End If
For i = 1 To nt
Set wr = oWordDoc.Range
With wr
.Collapse Direction:=wdCollapseEnd
.InsertParagraphAfter
.Collapse Direction:=wdCollapseEnd
End With
Set mt = oWordDoc.Tables.Add(Range:=wr, NumRows:=2, NumColumns:=2)
Next
counter = 1
tablen = 1
Do
For i = 1 To 2
For j = 1 To 2
Sheets("Charts").ChartObjects(counter).CopyPicture
oWordDoc.Tables(tablen).Cell(i, j).Range.Paste
If counter = nc Then Exit Do
If counter Mod 1 = 0 Then tablen = tablen + 1
counter = counter + 1
Next
Next
Loop Until counter = nc + 1
Exit Sub
Err_Handler:
MsgBox Err.Description, vbCritical, Err.Number
Resume Next
End Sub
Sub DataPaste()
Dim t As Word.Range, pn%, cn%
Data2Word
oWordDoc.Bookmarks("\EndofDoc").Select
pn = oWord.Selection.Information(wdActiveEndPageNumber)
Do
oWord.Selection.TypeParagraph
cn = oWord.Selection.Information(wdActiveEndPageNumber)
Loop Until cn = pn + 1 ' goes to a new page
Set t = oWord.Selection.Range
t.Paste
With oWordDoc.Tables(nt + 1)
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 100
.Borders(wdBorderTop).LineStyle = wdLineStyleSingle
.Borders(wdBorderLeft).LineStyle = wdLineStyleSingle
.Borders(wdBorderBottom).LineStyle = wdLineStyleSingle
.Borders(wdBorderRight).LineStyle = wdLineStyleSingle
.Borders(wdBorderHorizontal).LineStyle = wdLineStyleSingle
.Borders(wdBorderVertical).LineStyle = wdLineStyleSingle
.AutoFitBehavior (wdAutoFitWindow)
End With
Sheet34.Visible = xlSheetHidden
End Sub
Sub Data2Word()
Dim d As Worksheet
Set d = Worksheets("Temp")
Sheet34.Activate
Range("B8:O27").Select
Selection.Copy
End Sub
