0

我想将 Excel 中横向的打印区域复制到我运行代码的 Word 文档中。

我在用

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

复制该区域，但随着列宽的变化，它是没用的。

更新：

我正在使用它来计算 Word 文档中的可用尺寸

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

我试图缩放我的图像以适应：

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

它并不完全做到这一点。最好的方法是在复制之前设置图像范围。

更新2：

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")

这给出了一个错误：

Set rngTemp = ws.Range("A1")
4

1 回答 1

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
于 2013-01-22T10:24:16.153 回答