Copy and paste a Chart to a specified place in Word document?

[perola.rike]

I'm a psychologist experimenting with VBA/Excel to produce MS Word reports based on test-data (e.g. memory tests).
In sum, my code perfectly well produce a formatted text-report in word, it also copy the chart of interest (which is the psychological profile of the patient) and paste it into word.

BUT

The chart is pasted into the last word-page, and it hides the text below.

I wonder - is it possible to paste the chart at a specified position in the word-document so that it is not covering the text?

This is the code (with norwegian remarks), and the paste chart code is at the bottom...!

CODE:

Sub wordgeneratormedprofilark()


'Export Excel data to Word


'DEL 1.EXCEL

Sheets("generator").Visible = xlSheetVisible
Sheets("wordgenerator").Visible = xlSheetVisible
Sheets("profilark").Visible = xlSheetVisible
Sheets("W4_profilark").Visible = xlSheetVisible

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

'oppfrisker concatenate kodene så riktig test er med i tekst under profil
Application.CalculateFull

'vis_validitet
' koden over (dette er validitets makro, tror ikke det trengs med baseratemakro, kun concatenate som AppCalcFull tar...!
'HER!!!!!!!!!!!! bør også baserate/validitetsmakroene kjøres inn. Tror ikke med 100% sikkerhet at de kjører med CalcFull makro.

'"copygenerator" som kopierer celler til wordgenerator
Sheets("generator").Select
Range("E1:E600").Select
Selection.Copy
Sheets("wordgenerator").Select
Range("A1").PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

'Navngiving av celler!
'R2C1 osv må korresponderere til Range i wordgeneratoren (før feilkoder og tome ruter slettes), står det A4 er det r4c1!

'resymert fra med. innkomst
Range("A1").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="resymert_wgen", RefersToR1C1:= _
"=wordgenerator!R1C1"

'aktuelt overskrift
Range("A2").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Aktuelt_wgen", RefersToR1C1:= _
"=wordgenerator!R2C1"
Range("A3").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Aktuelttekst_wgen", RefersToR1C1:= _
"=wordgenerator!R3C1"

'egenrapportering overskrift
Range("A5").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Egenrapportering_wgen", RefersToR1C1:= _
"=wordgenerator!R5C1"

'egenrapporteringstekst (års utdanning, egenrapporteringsruten osv)
Range("A6").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Egenrapporteringtekst_wgen", RefersToR1C1:= _
"=wordgenerator!R6C1"

'nevropsykologiske testresultat overskrift
Range("A15").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="NPresultat_wgen", RefersToR1C1:= _
"=wordgenerator!R15C1"

'NPmerge, navngir ruta der all testbeskrivelse skal inn, concatenate av all NP test tekst
Range("A16").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="NPmerge", RefersToR1C1:= _
"=wordgenerator!R16C1"

Range("A17:A360").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="NPresultattekst_wgen", RefersToR1C1:= _
"=wordgenerator!R17C1:R360C1"

'benyttede tester overskrift
Range("A380").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="overskriftbenyttedetester_wgen", RefersToR1C1:= _
"=wordgenerator!R380C1"

'Domenene, totalt 8 stykker
Range("A382").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="sensomotorisk_wgen", RefersToR1C1:= _
"=wordgenerator!R382C1"

Range("A383").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="oppmerksomhet_wgen", RefersToR1C1:= _
"=wordgenerator!R383C1"

Range("A384").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="psykomotorisk_wgen", RefersToR1C1:= _
"=wordgenerator!R384C1"

Range("A385").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="hukommelse_wgen", RefersToR1C1:= _
"=wordgenerator!R385C1"

Range("A386").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="selvregulering_wgen", RefersToR1C1:= _
"=wordgenerator!R386C1"

Range("A387").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="språkkunnskap_wgen", RefersToR1C1:= _
"=wordgenerator!R387C1"

Range("A388").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="nonverbal_wgen", RefersToR1C1:= _
"=wordgenerator!R388C1"

Range("A389").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="visuospatial_wgen", RefersToR1C1:= _
"=wordgenerator!R389C1"

Range("A390").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="visuelloppmerksomhet_wgen", RefersToR1C1:= _
"=wordgenerator!R390C1"

'benyttede tilleggstester overskrift
Range("A398").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="overskrifttilleggstester_wgen", RefersToR1C1:= _
"=wordgenerator!R398C1"

'benyttede tilleggstester (celle som skal romme alle tilleggstester)
Range("A399").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="tilleggstester_wgen", RefersToR1C1:= _
"=wordgenerator!R399C1"

'Validititesindikatorer overskrift
Range("A451").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="overskriftvaliditetsindikatorer_wgen", RefersToR1C1:= _
"=wordgenerator!R451C1"

'Validitetsindikatorer (denne er en celle med concatenated indikatorer)
Range("A452").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="validitetsindikatorer_wgen", RefersToR1C1:= _
"=wordgenerator!R452C1"


'Baserate overskrift
Range("A471").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="overskriftbaserate_wgen", RefersToR1C1:= _
"=wordgenerator!R471C1"

'Baserate(denne er en celle med concatenated indikatorer)
Range("A472").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="baserate_wgen", RefersToR1C1:= _
"=wordgenerator!R472C1"

'Vurdering overskrift
Range("A494").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Vurdering_wgen", RefersToR1C1:= _
"=wordgenerator!R494C1"

Range("A495").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Vurderingtekst_wgen", RefersToR1C1:= _
"=wordgenerator!R495C1"

'legg merke til at det er ledig range A445 her! Der kan du lage en setning eller to du vil ha inn.

Range("A498").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Undersøker_wgen", RefersToR1C1:= _
"=wordgenerator!R498C1"

Range("A499").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Sted_wgen", RefersToR1C1:= _
"=wordgenerator!R499C1"

Range("A500").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Dato_wgen", RefersToR1C1:= _
"=wordgenerator!R500C1"

Range("A501").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Avdeling_wgen", RefersToR1C1:= _
"=wordgenerator!R501C1"

'Sletter feilkoder som DIV/0, N/A Name? og tommme celler i wordgeneratorfanen
On Error Resume Next
Columns("A:A").SpecialCells(xlCellTypeFormulas, 16).EntireRow.Delete

'Merge makro. Concatenates alle np tester og benyttede tester i en celle med navn "NPmerge"
merge


'DEL 2.WORD - Mot Word og forbi (Buzz Lightyear, som ikke kan fly men faller med stil)


Dim WordApp As Object
Dim LastRow As Integer, i As Integer, r As Integer, Records As Integer
On Error Resume Next
Application.ScreenUpdating = False

'Start Word And create an Object
'hvis jeg re-insetter with wordapp .doc add så lagres alle disse word documentene???...tror jeg
Set WordApp = CreateObject("Word.Application")
SaveAsName = ThisWorkbook.Path & "\" & "Autorapport " & savename & ".doc"

'Sletter tomme celler
LastRow = Selection.SpecialCells(xlCellTypeLastCell).Rows.Row
Application.StatusBar = "Produserer rapport. Krypteringshastighet: " & LastRow & " MB/s."
'Cycle through all records In Items
On Error Resume Next
For r = LastRow To 1 Step -1
If Application.WorksheetFunction.CountA(Rows(r)) = 0 Then Rows(r).Delete
Next r

'Update Last Row value In Case rows were deleted
'Sheets("wordgenerator").Range("A1:A200").FormatConditions.Delete
Records = ActiveSheet.UsedRange.Rows.Count

'Word: Navngitte cellers innhold som skal inn i word defineres her
Set Data = Sheets("wordgenerator").Range("A1")
resymert_wgen = Sheets("wordgenerator").Range("resymert_wgen")
Aktuelt_wgen = Sheets("wordgenerator").Range("Aktuelt_wgen")
Aktuelttekst_wgen = Sheets("wordgenerator").Range("Aktuelttekst_wgen")
Egenrapportering_wgen = Sheets("wordgenerator").Range("Egenrapportering_wgen")
Egenrapporteringtekst_wgen = Sheets("wordgenerator").Range("Egenrapporteringtekst_wgen")
NPresultat_wgen = Sheets("wordgenerator").Range("NPresultat_wgen")
NPmerge = Sheets("wordgenerator").Range("NPmerge")
overskriftbenyttedetester_wgen = Sheets("wordgenerator").Range("overskriftbenyttedetester_wgen")
sensomotorisk_wgen = Sheets("wordgenerator").Range("sensomotorisk_wgen")
oppmerksomhet_wgen = Sheets("wordgenerator").Range("oppmerksomhet_wgen")
psykomotorisk_wgen = Sheets("wordgenerator").Range("psykomotorisk_wgen")
hukommelse_wgen = Sheets("wordgenerator").Range("hukommelse_wgen")
selvregulering_wgen = Sheets("wordgenerator").Range("selvregulering_wgen")
språkkunnskap_wgen = Sheets("wordgenerator").Range("språkkunnskap_wgen")
nonverbal_wgen = Sheets("wordgenerator").Range("nonverbal_wgen")
visuospatial_wgen = Sheets("wordgenerator").Range("visuospatial_wgen")
visuelloppmerksomhet_wgen = Sheets("wordgenerator").Range("visuelloppmerksomhet_wgen")

'de nye greiene
overskrifttilleggstester_wgen = Sheets("wordgenerator").Range("overskrifttilleggstester_wgen")
tilleggstester_wgen = Sheets("wordgenerator").Range("tilleggstester_wgen")
overskriftvaliditetsindikatorer_wgen = Sheets("wordgenerator").Range("overskriftvaliditetsindikatorer_wgen")
validitetsindikatorer_wgen = Sheets("wordgenerator").Range("validitetsindikatorer_wgen")

overskriftbaserate_wgen = Sheets("wordgenerator").Range("overskriftbaserate_wgen")
baserate_wgen = Sheets("wordgenerator").Range("baserate_wgen")


Vurdering_wgen = Sheets("wordgenerator").Range("Vurdering_wgen")
Vurderingtekst_wgen = Sheets("wordgenerator").Range("Vurderingtekst_wgen")
Undersøker_wgen = Sheets("wordgenerator").Range("Undersøker_wgen")
Sted_wgen = Sheets("wordgenerator").Range("Sted_wgen")
Dato_wgen = Sheets("wordgenerator").Range("Dato_wgen")
Avdeling_wgen = Sheets("wordgenerator").Range("Avdeling_wgen")

'Cycle through all records In Items (det er denne som tar tid?)
'her fjerna jeg masse som muligens blokkerte hele ****en????

'Send commands To Word - dette er tekst som nå er formatert som sendes i den nøyaktige rekkefølge det står i word
Application.ScreenUpdating = False
With WordApp
.Documents.Add
With .Selection
.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=resymert_wgen
.TypeParagraph '(linjeskift)

'aktuelt (sjekk ut aktuelt gen og aktuelttekst!
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.TypeText Text:=Aktuelt_wgen
.TypeParagraph
.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=Aktuelttekst_wgen
.TypeParagraph

'egenrapportering
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.TypeText Text:=Egenrapportering_wgen
.TypeParagraph
.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=Egenrapporteringtekst_wgen
.TypeParagraph

'NP resultater
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.TypeText Text:=NPresultat_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=NPmerge
.TypeParagraph

'Følgende tester inngår i de ulike domenene i profilark
'jeg tror det kan lages med kursiv hvis man ikke taster paragraph, men da må også den cellen navngis, altså ett ekste ledd som er ganske mye programmering.....! en egen med font, tekst sm: osv
'kan kortes ved å clustre de som ikke er overskrifter, feks alle domenene
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.TypeText Text:=overskriftbenyttedetester_wgen
.TypeParagraph

'i generator må man ikke linke b og d celler fra profilarksheet. Plusse på en egen frase her med italic, voila!
.Font.Size = 11
.Font.Bold = False
.Font.Italic = True
.ParagraphFormat.Alignment = 0
.TypeText Text:="Sensomotorisk: "
.Font.Italic = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=sensomotorisk_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.Font.Italic = True
.ParagraphFormat.Alignment = 0
.TypeText Text:="Oppmerksomhet: "
.Font.Italic = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=oppmerksomhet_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.Font.Italic = True
.ParagraphFormat.Alignment = 0
.TypeText Text:="Psykomotorisk: "
.Font.Italic = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=psykomotorisk_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.Font.Italic = True
.ParagraphFormat.Alignment = 0
.TypeText Text:="Hukommelse: "
.Font.Italic = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=hukommelse_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.Font.Italic = True
.ParagraphFormat.Alignment = 0
.TypeText Text:="Selvreguleringsfunksjoner: "
.Font.Italic = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=selvregulering_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.Font.Italic = True
.ParagraphFormat.Alignment = 0
.TypeText Text:="Språk og kunnskap: "
.Font.Italic = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=språkkunnskap_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.Font.Italic = True
.ParagraphFormat.Alignment = 0
.TypeText Text:="Nonverbale funksjoner: "
.Font.Italic = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=nonverbal_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.Font.Italic = True
.ParagraphFormat.Alignment = 0
.TypeText Text:="Visuospatiale funksjoner: "
.Font.Italic = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=visuospatial_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.Font.Italic = True
.ParagraphFormat.Alignment = 0
.TypeText Text:="Visuell oppmerksomhet: "
.Font.Italic = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=visuelloppmerksomhet_wgen
.TypeParagraph

'Tilleggstester
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.TypeText Text:=overskrifttilleggstester_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=tilleggstester_wgen
.TypeParagraph

'Validitetsindikatorer
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.TypeText Text:=overskriftvaliditetsindikatorer_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=validitetsindikatorer_wgen
.TypeParagraph

'Baserate
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.TypeText Text:=overskriftbaserate_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=baserate_wgen
.TypeParagraph


'vurdering
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.TypeText Text:=Vurdering_wgen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.TypeText Text:=Vurderingtekst_wgen
.TypeParagraph
.TypeText Text:=Undersøker_wgen
.TypeParagraph
.TypeText Text:=Sted_wgen
.TypeParagraph
.TypeText Text:=Dato_wgen
.TypeText Text:=Format(Date, "d. mmmm yyyy")
.TypeParagraph
.TypeText Text:=Avdeling_wgen

End With

End With

'Copy/paste profilchart, legger seg dog oppå texten...
'Dim word As Object
Dim doc As Object

Dim chrt As ChartObject
'Dim i As Integer

On Error Resume Next
'(For i = 1 To 1)
Sheets("profilark").Activate


'her finner man, og aktiverer, det siste chart som er lagt til i arket, det forandrer stadig navn når man kjører koden flere ganger...



For Each chrt In ActiveSheet.ChartObjects


i = i + 1


Next






ActiveSheet.ChartObjects.Item(i).Activate



'ActiveSheet.ChartObjects("Chart 9").Activate
ActiveChart.CopyPicture Appearance:=xlScreen, Format:=xlPicture
With WordApp.Selection
'Paste Chart
.Range.PasteSpecial
End With

'Save the Word file And Close it (kanskje vi bare skal åpne dokumentet i stedet for lagre-kanskje det spare disse temp filene?)
With WordApp
.ActiveDocument.SaveAs Filename:=SaveAsName
.ActiveWindow.Close
' Kill the Object
.Quit
End With

Set word = Nothing
'Reset status bar
Application.StatusBar = ""
MsgBox "Autorapport " & savename & ".doc ble lagret i " & ThisWorkbook.Path
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic

'Sheets("generator").Visible = xlSheetVeryHidden
'Sheets("wordgenerator").Visible = xlSheetVeryHidden
Sheets("profilark").Visible = xlSheetVeryHidden
Sheets("W4_profilark").Visible = xlSheetVeryHidden
Sheets("NP Skåring").Activate
End Sub

 

[Andrew Poulsom]

This may help you:

Using Excel with Other Office Applications