AW: Grafik in neues Worddokument kopieren
24.07.2013 15:19:19
fcs
Hallo Ann,
beim Einfügen als Grafik in Word kann ich dir helfen.
Für die Anpassung der Größe der eingefügten Grafik hab ich nichts passendes gefunden, und Word ist beim Versuch die Größenanpassung per Recorder aufzuzeichnen immer abgestürzt.
Als Notlösungen
1. Du machst dein Diagramm in Excel so Groß, wie es in Word sein soll
2. Das Makro vergrößert vor dem Kopieren das Diagramm, und verkleinert es nach dem Einfügen wieder
Nachteil: Beschriftungen werden nicht proportional mit vergrößtert.
3. Du kopierst dein Diagramm und verschiebst es auf ein separates Diagrammblatt
Über die Seitenränder kannst du die Größe für Word optimieren.
Für das Kopieren nach Word benutzt du dann dieses Blatt.
Gruß
Franz
Makrobeispiele:
Sub copyandpasteChart()
Dim heightOld As Double, widthold As Double
Dim objChartObject As ChartObject
Set objChartObject = Sheets("Tabelle2").ChartObjects(1)
With objChartObject
.Activate
HoeheAlt = .Height
BreiteAlt = .Width
'Höhe/Breite für Word anpassen
.Height = 1.4 * HoeheAlt
.Width = 1.4 * BreiteAlt
.Chart.ChartArea.Copy
End With
Dim word As Object
Set wordApp = CreateObject("word.application")
With wordApp
.Visible = True
.Documents.Add
.activedocument.PageSetup.Orientation = 1
.Selection.PasteSpecial Link:=False, DataType:=15, Placement:=0, _
DisplayAsIcon:=False ' Placement: 0 = wdInLine (in zeile mit Text
End With
With objChartObject
'Höhe/Breite zurücksetzen
.Height = HoeheAlt
.Width = BreiteAlt
End With
End Sub
Sub copyandpasteChart_2()
'Kopieren der Chartarea eines Diagrammblattes
'Die optimale Bildgröße für die Grafik in Word kann man über die Seitenränder _
des Diagramms einstellen
Dim objChartObject As Chart
Set objChartObject = Sheets("Diagramm1")
With objChartObject
.Activate
.ChartArea.Copy
End With
Dim word As Object
Set wordApp = CreateObject("word.application")
With wordApp
.Visible = True
.Documents.Add
.activedocument.PageSetup.Orientation = 1
.Selection.PasteSpecial Link:=False, DataType:=15, Placement:=0, _
DisplayAsIcon:=False ' Placement: 0 = wdInLine (in zeile mit Text
End With
End Sub