VBA to copy from Excel as image and paste in Word

[Diag]

Hello,

I am new to the forum and I use VBA not very often. I have used the code (similar to the code mentioned in the link below).

VBA to copy from Excel as image and paste in Word

I found some code that basically does what I need, but I need it to paste in as a picture. What needs to change for that? Thank you for any help! Sub CopyWorksheetsToWord() Dim wdApp As Word.Application, wdDoc As Word.Document, ws As Worksheet Application.ScreenUpdating = False...

www.mrexcel.com

When I use the code it works fine, but I get the popup message that the image is too big and that it will be cut. when viewing the image in word, it is not fitted correctly. My data is in Range A1:O58.

the program I use is:
-------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub SaveXlRangeToWordFile()

Dim ObjPic As Object, Ws As Worksheet
Dim WdDoc As Object, WdApp As Object

'open Word application
On Error Resume Next
Set WdApp = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set WdApp = CreateObject("Word.Application")
End If

'open doc **********change file path to suit
On Error GoTo erfix
Set WdDoc = WdApp.Documents.Open(Filename:="C:\Users\******\********\******\test.docx")
For Each Ws In ActiveWorkbook.Worksheets
Application.StatusBar = "Copying data from " & Ws.Name & "sheets"

Ws.UsedRange.Copy '

WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.PasteSpecial DataType:=3 '9 '4
Application.CutCopyMode = False
WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range.InsertParagraphAfter

If Not Ws.Name = Worksheets(Worksheets.Count).Name Then

With WdDoc.Paragraphs(WdDoc.Paragraphs.Count).Range
.InsertParagraphAfter
.Collapse Direction:=0 'wdCollapseEnd
.InsertBreak Type:=7 'wdPageBreak
End With
End If
Next Ws

'pictures in newxl version are converted to inlineshapes
'takes time to paste and convert
'Application.Wait (Now + TimeValue("0:00:02"))
'For Each ObjPic In WdApp.ActiveDocument.InlineShapes
'ObjPic.ConvertToShape
'Next ObjPic
WdApp.ActiveDocument.Close savechanges:=True
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Application.StatusBar = False
'Set ObjPic = Nothing
Exit Sub

erfix:
On Error GoTo 0
MsgBox "Save SaveXlRangeToWordFile error"
WdApp.ActiveDocument.Close savechanges:=False
Set WdDoc = Nothing
WdApp.Quit
Set WdApp = Nothing
Application.CutCopyMode = False
Application.StatusBar = False
'Set ObjPic = Nothing
End Sub
----------------------------------------------------------------------------------------------------------------------------------
Can someone maybe help me with the program to autofit the picture to word?

Thanks

 

[NdNoviceHlp]

Hi Diag and Welcome to the Board. See this thread re. addition of page setup etc. HTH. Dave

How can i save a sheet as a word document?

Hi Everyone, I have a sheet that i current save as a PDF, some have asked if there could have a Word copy, the sheet is set up to be a few sheets and i currently get the Print Area from: PrintArea Sheets("Proposal").Range("EP99") what i need is some VBA to create a word document of the sheet...

www.mrexcel.com

 

[Diag]

Hi Diag and Welcome to the Board. See this thread re. addition of page setup etc. HTH. Dave

How can i save a sheet as a word document?

Hi Everyone, I have a sheet that i current save as a PDF, some have asked if there could have a Word copy, the sheet is set up to be a few sheets and i currently get the Print Area from: PrintArea Sheets("Proposal").Range("EP99") what i need is some VBA to create a word document of the sheet...

www.mrexcel.com

Hi Dave Thanks for your reply,

I worked on the code you send and it works. The only thing is that the bottom of my sheet is cut off in the picture when it is loaded in word. The last 5 cm is missing. The width is ok.
Is there a possibility to zoom or autofit the picture in word? The range (A1:O58) I need to work with is fixed. the sheets are generated by a macro provided by the manufacturer of a measurement device.

thanks in advance,

Regards Frans

 

[NdNoviceHlp]

Hi Frans. You can trial setting the scaleheight. Adjust the 0.85 to whatever number works (.085 is 85% of original height). Dave

'size range pic to sheet
With WdDoc.Shapes(Cnt)
.LockAspectRatio = msoFalse
.Width = WidthAvail
.ScaleHeight 0.85, False
End With]/code]

 

[Diag]

Hi Dave,

I did the test and it works great,
thanks!!!!

 

[NdNoviceHlp]

You are welcome. Thanks for posting your outcome. Dave

 

[Diag]

Hi,

I am still working on the project and making progress step by step. The code mentioned below copies the excel sheet from excel to word.

The problem I run into at the moment is: In the "normal excel program" everything works perfectly. When I copy the macro/ userform to the ribbon I get the error:

error 9 => subscript out of range

the error occurs in line:
ActiveWorkbook.Worksheets(names).ChartObjects(1).Activate

I already tried,
=>Thisworkbook to Activeworkbook
=> (names) seems to be read correctly (local variables panel)

In the "normal program" everything works perfectly. When I copy/import the macro and userform to the personal macro workbook and use it from the ribbon I get the error.

I hope someone can help me to solve the error.

Private Sub CommandButton3_Click()

    Dim names           As Variant
    Dim checkbox        As Control
    Dim fileSave        As Variant
    Dim msg             As Integer
    Dim actvsheet       As String
    Dim myRange         As Variant
    
    Application.ScreenUpdating = False

    a = 1

    'Get the active sheet name to return to the current sheet after the task is done.
    actvsheet = ActiveWorkbook.ActiveSheet.Name
    
    'Let's the user choose the path to save the file
    Set fileSave = Application.FileDialog(msoFileDialogSaveAs)
    
           'Using Early Binding
        
            Dim wordApp As Word.Application
        
            Dim mydoc As Word.Document
        

            'Creating a new instance of word only if there no other instances
        
            Set wordApp = New Word.Application
        
        
            'Making word App Visible
        
            wordApp.Visible = True
                   
        
            'Creating a new document
        
            Set mydoc = wordApp.Documents.Add()
            Set WdObj = CreateObject("Word.Application")
            WdObj.Visible = True
    

    'The UserForm has checkboxes. Each checkbox has a caption after a sheetname. This for loop checks which sheets are selected by the user to be printed.
    For Each checkbox In Me.Controls
        If TypeName(checkbox) = "CheckBox" Then
            If checkbox.Value = True Then
                names = checkbox.Caption
                
        
            'copying the content from excel sheet
        
            Dim iTotalRows As Integer   ' GET TOTAL USED RANGE ROWS.
            'iTotalRows = ThisWorkbook.Worksheets(names).UsedRange.Rows.Count
            iTotalRows = 57
            ActiveWorkbook.Worksheets(names).ChartObjects(1).Activate
            Dim iTotalCols As Integer   ' GET TOTAL COLUMNS.
            
            'iTotalCols = ThisWorkbook.Worksheets(names).UsedRange.Columns.Count
            iTotalCols = 16
            Dim colName As Variant
            colName = Split(Cells(1, iTotalCols).Address, "$")(1)
            Dim Dest As String
            Dest = "A1:" & colName & iTotalRows
            Range(Dest).Copy
          
          
        
            'Pause the application for two seconds
            Application.Wait Now + #12:00:02 AM#
        
            'Pasting on the document
            
            With wordApp.Selection
            .PasteSpecial Link:=True, DataType:=wdPasteOLEObject
            End With
            
            
            wordApp.ActiveDocument.Sections.Add
            wordApp.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
           
        
            'Emptying the Clipboard
        
            CutCopyMode = False
              
                    End If
                End If
            Next
            'saving the document
            With Dialogs(wdDialogFileSaveAs)
            .Name = "c:\"
            .Show
            End With

                    
    
    
End Sub

 

[NdNoviceHlp]

Is "names" the name of your sheet? If it is...

ActiveWorkbook.Worksheets("names").ChartObjects(1).Activate

You need quotation marks around the sheet name. You are also creating 2 Word applications instead of just using one. You can remove these 2 lines of code...

Set WdObj = CreateObject("Word.Application")
            WdObj.Visible = True

HTH. Dave

 

[Diag]

Hello Dave,

Thanks for your reply. The sheet names are just numbered 1,2,3,4 etc. See image #1. These "names" are corresponding to the userform checkboxes(see image #2). This part of code refers to them :
names = checkbox.Caption

When I run the code I can see the correct name mentioned in the local variables table. So based on that I suggested that the "names" part should be fine(see image #3). My guess was the ChartObjects.Activate part that gives the error when running in the personal macro workbook. but not sure how to solve the issue seeing the fact that it works properly in the normal excel file.

hope you can help

Thanks

 

[NdNoviceHlp]

Missed the Names being checkbox captions part of the code. This "should" work...

Dim ws As Worksheet, Names As String
Set ws = ActiveWorkbook.Sheets(Names)
ws.ChartObjects(ws.ChartObjects.Count).Activate

Dave