VBA将Excel图表复制到Word作为图片更改图表大小

我想创建一个宏，从Excel复制图表，并将它们作为图片粘贴到Word中（最好是增强的图元文件）

我设置了一个Word模板文档，其中有一个表格，在图片应该插入的特定单元格中包含书签

然而，在我当前的代码中，插入的图像太大，把整个表都搞糟了。 我尝试了不同的图片选项（增强的图元文件、png等），但它们都有相同的结果

当我尝试在表中使用

PasteSpecial

手动复制图表时，它会保持原始大小，这正是我想要的大小

我需要在代码中修改什么才能得到它

Sub CopyCharts2Word()

Dim wd As Object
Dim ObjDoc As Object
Dim FilePath As String
Dim FileName As String
FilePath = "C:\Users\Name\Desktop"
FileName = "Template.docx"


'check if template document is open in Word, otherwise open it
On Error Resume Next
Set wd = GetObject (, "Word.Application")    
If wd Is Nothing Then
    Set wd = CreateObject("Word.Application")
    Set ObjDoc = wd.Documents.Open(FilePath & "\" & FileName)
Else
    On Error GoTo notOpen
    Set ObjDoc = wd.Documents(FileName)
    GoTo OpenAlready
notOpen:
    Set ObjDoc = wd.Documents.Open(FilePath & "\" & FileName)
End If
OpenAlready:
On Error GoTo 0

'find Bookmark in template doc 
wd.Visible = True                                              
ObjDoc.Bookmarks("Boomark1").Select  

 'copy chart from Excel        
 Sheets("Sheet1").ChartObjects("ChartA").chart.ChartArea.Copy        

 'insert chart to Bookmark in template doc
 wd.Selection.PasteSpecial Link:=False, _
 DataType:=wdPasteMetafilePicture, _
 Placement:=wdInLine, _
 DisplayAsIcon:=False

 End Sub

是的，就是这样：

我换了

'insert chart to Bookmark in template doc
wd.Selection.PasteSpecial Link:=False, _
DataType:=wdPasteMetafilePicture, _
Placement:=wdInLine, _
DisplayAsIcon:=False

与

---

这样，图表的大小与Excel工作表中的大小相同

拉斐尔，谢谢你。我用了你解决方案的一部分。当我从excel创建新word文档时，我的问题是书签。我没有找到更好的书签解决方案，所以我看了不同的网站，这是我的解决方案（感谢来自不同网站和Stackoverflow的所有答案）

Sub-Kpyla\u Click（）

ErrHandler1：
MsgBox（“无图表”）
退出子系统

End Sub

手动复制/粘贴时是否尝试记录宏并比较代码？是的，问题是，它只记录我在Excel中所做的操作（即选择并复制图表，而不是如何将其插入Word文档）。当我尝试在Word中记录粘贴图表的宏时，它不允许我选择要插入图表的表。当您手动粘贴时，位置是什么？我相信它是紧的而不是直列的。word也有内嵌的形状，看看吧。那会有帮助的。谢谢cyboashu，这是正确的线索：紧身有助于保持体型！在Word中插入图表后，我试图调整它的大小，但我很难处理内联形状，因为它在表中。。。

wd.Selection.PasteSpecial Link:=False, _
DataType:=wdPasteMetafilePicture, _
Placement:=wdTight, _    
DisplayAsIcon:=False

Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Dim wdRng As Word.Range
Dim crt As Object
Dim pic As Word.Shape
Dim ust As Word.Range

Kpyla.Caption = "E->W"
Kpyla.Font.Size = 14
Kpyla.Height = 25
Kpyla.Width = 40
Kpyla.Top = 60
Kpyla.Left = 180
Kpyla.Visible = True

On Error GoTo ErrHandler1
Set crt = ActiveSheet.ChartObjects(1)
MsgBox ("Active Chart")
crt.Activate

On Error Resume Next
Set wdApp = GetObject(, "Word.Application")

If wdApp Is Nothing Then
    MsgBox ("Creating New")
    Set wdApp = New Word.Application
    Set wdDoc = wdApp.Documents.Add
Else
    MsgBox ("Active")
    Set wdDoc = wdApp.ActiveDocument
End If

wdApp.Visible = True

With wdDoc.PageSetup
    .Orientation = wdOrientLandscape
    .TopMargin = wdApp.InchesToPoints(0.25)
    .BottomMargin = wdApp.InchesToPoints(0.25)
    .LeftMargin = wdApp.InchesToPoints(0.25)
    .RightMargin = wdApp.InchesToPoints(0.25)
    .HeaderDistance = wdApp.InchesToPoints(1)
    .FooterDistance = wdApp.InchesToPoints(1)
End With
Set ust = wdDoc.Sections.Item(1).Headers(wdHeaderFooterPrimary).Range
ust.Text = "" & vbNewLine

With wdApp.Selection
    .ParagraphFormat.Alignment = wdAlignParagraphCenter
End With

crt.Chart.ChartArea.Copy

Set wdRng = wdDoc.ActiveWindow.Selection.Range
wdRng.PasteSpecial Link:=False, DataType:=wdPasteMetafilePicture, Placement:=wdTight, DisplayAsIcon:=True

wdDoc.Content.Select '''/

With wdApp.Selection
    .Collapse Direction:=0
    .InsertBreak Type:=7
End With

MsgBox ("Ending")
Exit Sub