Copy a range as picture in Excel, then export and paste it in Word VBA?

[perola.rike]

Below I have a code that exports text from Excel and paste it to word in specified orders and formatting. Some of the words and comments are in Norwegian. I'm sure this code can be shorter and faster .

But what I need is a way to incorporate a procedure that copies a named range in excel (Sheets(NP skåring).Range("profilark")), and paste this range as a picture in MS Word. In the same code shown below.

Is it possible?
Any suggestions are very welcome!

Best regards,
Per-Ola


Sub wordgenerator()




'Creates Word document of Auction Items using Automation


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

'copygenerator
Sheets("generator").Select
Range("G12:G130").Select
Selection.Copy
Sheets("wordgenerator").Select
Range("A1").Select
ActiveSheet.Paste


'name that range!
'resymert
Range("A2").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="resymert_gen", RefersToR1C1:= _
"=wordgenerator!R2C1"
Range("A3").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="resymerttekst_gen", RefersToR1C1:= _
"=wordgenerator!R3C1"
'aktuelt
Range("A4").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Aktuelt_gen", RefersToR1C1:= _
"=wordgenerator!R4C1"
Range("A5").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Aktuelttekst_gen", RefersToR1C1:= _
"=wordgenerator!R5C1"
'egenrapportering
Range("A8").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Egenrapportering_gen", RefersToR1C1:= _
"=wordgenerator!R8C1"
Range("A9:A24").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Egenrapporteringtekst_gen", RefersToR1C1:= _
"=wordgenerator!R9C1:R24C1"
'nevropsykologiske testresultat
Range("A25").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="NPresultat_gen", RefersToR1C1:= _
"=wordgenerator!R25C1"
Range("A26").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="NPmerge", RefersToR1C1:= _
"=wordgenerator!R26C1"

Range("A27:A100").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="NPresultattekst_gen", RefersToR1C1:= _
"=wordgenerator!R27C1:R100C1"
'Vurdering
Range("A101").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Vurdering_gen", RefersToR1C1:= _
"=wordgenerator!R101C1"

Range("A102").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Vurderingtekst_gen", RefersToR1C1:= _
"=wordgenerator!R102C1"

Range("A106").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Sted_dato", RefersToR1C1:= _
"=wordgenerator!R106C1"

Range("A107").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Undersøker_gen", RefersToR1C1:= _
"=wordgenerator!R107C1"

Range("A108").Select
Application.CutCopyMode = False
ActiveWorkbook.Names.Add Name:="Avd_sykehus", RefersToR1C1:= _
"=wordgenerator!R108C1"

'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

'samler alle np tester i en celle!

merge

'Mot MS Word og forbi

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
Set WordApp = CreateObject("Word.Application")
With WordApp
.Documents.Add
End With

' Lagre som navn og path
WSName = "Oppstart"
'change "Sheet1" to sheet tab name containing cell reference
CName = "Navn"
'change "A1" to the cell with your date
'savename = Sheets(WSName).Range(CName).Text
SaveAsName = ThisWorkbook.Path & "\" & "Autorapport " & savename & ".doc"


'Sorterer eventuelt tekstlinjene alfabetisk - trengs ikke
Sheets("wordgenerator").Range("A1").Select
' Cells.Select
' Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, _
' Key2:=Range("B2"), Order2:=xlAscending, _
' Key1:=Range("C2"), Order3:=xlAscending, Header:=xlGuess, _
'OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
'Range("A2").Select


' Sletter tomme celler
LastRow = Selection.SpecialCells(xlCellTypeLastCell).Rows.Row
Application.StatusBar = "Deleting Empty Rows from " & LastRow & " Used Rows"
' 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



'Information from worksheet (her må du legge inn alle navn/range på celler som skal i autorapport
Set Data = Sheets("wordgenerator").Range("A1")

resymert_gen = Sheets("wordgenerator").Range("resymert_gen")
Aktuelt_gen = Sheets("wordgenerator").Range("Aktuelt_gen")
Aktuelttekst_gen = Sheets("wordgenerator").Range("Aktuelttekst_gen")
Egenrapportering_gen = Sheets("wordgenerator").Range("Egenrapportering_gen")
Egenrapporteringtekst_gen = Sheets("wordgenerator").Range("Egenrapporteringtekst_gen")
'profilark = Sheets("wordgenerator").Range("profilark")
NPresultat_gen = Sheets("wordgenerator").Range("NPresultat_gen")
NPmerge = Sheets("wordgenerator").Range("NPmerge")
NPresultattekst_gen = Sheets("wordgenerator").Range("NPresultattekst_gen")
Vurdering_gen = Sheets("wordgenerator").Range("Vurdering_gen")
Vurderingtekst_gen = Sheets("wordgenerator").Range("Vurderingtekst_gen")
Sted_dato = Sheets("wordgenerator").Range("Sted_dato")
Undersøker_gen = Sheets("wordgenerator").Range("Undersøker_gen")
Avd_sykehus = Sheets("wordgenerator").Range("Avd_sykehus")


' Cycle through all records In Items

For i = 2 To Records
' Update status bar progress message
Application.StatusBar = "Processing Record " & i & " of " & Records

' Assign current data To variables
Letter = Data.Offset(i - 1, 0).Value
Number = Data.Offset(i - 1, 1).Value
Title = Data.Offset(i - 1, 2).Value
Descript = Data.Offset(i - 1, 3).Value
FMV = Format(Data.Offset(i - 1, 4).Value, "#,000")
FMText = Data.Offset(i - 1, 5).Value
Donor = Data.Offset(i - 1, 6).Value

'Send commands To Word
'her er rangenavn brukt, klarer kun en linje av gangen! Hvordan eksportere Range som NPresultattekst?
With WordApp
.Documents.Add
With .Selection
.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.Typetext Text:=resymert_gen
.TypeParagraph ' denne lager linjeskift

'aktuelt
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.Typetext Text:=Aktuelt_gen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.Typetext Text:=Aktuelttekst_gen
.TypeParagraph

'egenrapportering
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.Typetext Text:=Egenrapportering_gen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.Typetext Text:=Egenrapporteringtekst_gen
.TypeParagraph


'NP resultater
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.Typetext Text:=NPresultat_gen
.TypeParagraph
.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.Typetext Text:=NPmerge
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.Typetext Text:=NPresultattekst_gen
.TypeParagraph

'vurdering
.Font.Size = 11
.Font.Bold = True
.ParagraphFormat.Alignment = 0
.Typetext Text:=Vurdering_gen
.TypeParagraph

.Font.Size = 11
.Font.Bold = False
.ParagraphFormat.Alignment = 0
.Typetext Text:=Vurderingtekst_gen
.TypeParagraph
.Typetext Text:=Sted_dato
.TypeParagraph
.Typetext Text:=Undersøker_gen
.TypeParagraph
.Typetext Text:=Avd_sykehus


End With

End With
Next i

'where do I put a code that copy the range profilark and paste it into the same word document?
With WordApp
Range("profilark").Select
Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Selection.Paste
End With

' Save the Word file And Close it
With WordApp
.ActiveDocument.SaveAs Filename:=SaveAsName
.ActiveWindow.Close
' Kill the Object
.Quit
End With

Set WordApp = Nothing

' Reset status bar
Application.StatusBar = ""
MsgBox "Autorapport " & savename & ".doc was saved in " & ThisWorkbook.Path

Sheets("generator").Visible = xlSheetVeryHidden
Sheets("wordgenerator").Visible = xlSheetVeryHidden
End Sub