Copy Excel print area to Word

Question

I want to copy the print area for landscape in Excel to my Word document, where I run the code from.

I am using

wb.Sheets("Sheet1").Range("A1:N33").Copy

to copy the area, but as the column width changes, it's useless.

Update:

I am using this to calculate my usable dimensions in my Word Document

With ActiveDocument.PageSetup
      UsableWidth = .PageWidth - .LeftMargin - .RightMargin
      UsableHeight = .PageHeight - .TopMargin - .BottomMargin
End With

I tried to scale my image to fit with:

Selection.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdInLine, DisplayAsIcon:=False
Selection.ShapeRange.Height = UsableHeight
Selection.ShapeRange.Width = UsableHeight

It does not quite do it. The best approach would be to set the image range before it copies.

Update2:

Dim objExcel As New Excel.Application
Dim wb As Excel.Workbook
Dim ws As Excel.Worksheet
Set wb = objExcel.Workbooks.Open("C:\test.xlsx")
Set ws = wb.Sheets("Sheet1")

This gives an error:

Set rngTemp = ws.Range("A1")

Answer 1

You can retrieve the print area information using this code:

Sub GetPrintArea()

Dim rngPrintArea As Range

'Put print area into range variable
Set rngPrintArea = Sheet1.Range(Sheet1.PageSetup.PrintArea)

'Perform operations on range - shows up in Immediate window:
Debug.Print rngPrintArea.Height
Debug.Print rngPrintArea.Width
Debug.Print rngPrintArea.Cells(rngPrintArea.Rows.Count, rngPrintArea.Columns.Count).Address

End Sub

This does not work if a print area is not already set - can you confirm if the Excel sheets are already set to landscape with a print area defined? If not, you'll need to find the paper dimensions and loop through cells until you find those which share the same Left and Top values (I think). You can set the PrintArea like this:

'Set print area
Sheet1.PageSetup.PrintArea = "$A1:$N33"

---

EDIT - This should do what you need now we know that the source dimensions are predefined - you'll need to set UseableWidth and UseableHeight in Word and either bring them into this sub using ByVal or a public variable:

Sub FindRange()

Dim rngTemp As Range, rngCopy As Range, rngTest As Range
Dim iCol As Integer, iRow As Integer

Set rngTemp = Sheet1.Range("A1")

'Get closest column
Do Until rngTemp.Left >= UseableWidth
        Set rngTemp = rngTemp.Offset(0, 1)
Loop
iCol = rngTemp.Column

'Get closest row
Do Until rngTemp.Top >= UseableHeight
        Set rngTemp = rngTemp.Offset(1, 0)
Loop
iRow = rngTemp.Row

Set rngCopy = Sheet1.Range("A1", Sheet1.Cells(iRow, iCol))

'Copy rngCopy into Word as you were before

End Sub