AW: Worddokument: Excel-Objekte in Wordtabellen
09.05.2010 11:31:47
fcs
Hallo John,
hier meine Sonntags-Bastelarbeit. Ich wollte mich hier jetzt nicht zu sehr in die Tiefen der Word-Objektwelt begeben. Deshalb auch einige Select- und Activate-Anweisungen in der Prozedur. Die Ansicht wird auch immer zwischen Word und Excel wechseln.
Probier es erst einmal mit einer Kopie des Worddokuments.
Es könnte sein, dass die Position der eingebetteten Excel-Tabellen nicht immer optimal ermittelt wird.
Du muss auch noch die optimale Einfüge-Methode probieren - 3 Varianten sind eingebaut, davon 2 als Kommentar.
Gruß
Franz
Option Explicit
'Erstellt unter Office 2007 - 2010-05-09 - fcs
'Dieses Makro in Word in der Normal.dot in einem allgemeinen Modul speichern
Sub ExcelObjekte_in_Wordtabellen_Konvertieren()
'Wandelt eingebettete Exceltabellen-Objekte in Wordtabellen um
Dim oDoc As Document, oShape As Shape, rngPosition As Range
Dim iCount As Long
Dim xlApp As Object, LastColumn As Long, LastRow As Long
Dim Zeile As Long, Spalte As Long
If MsgBox("Im aktiven Dokument alle eingebetteten Excel-Tabellen " & _
"in Word-Tabellen umwandeln?", vbYesNo + vbQuestion + vbDefaultButton2, _
"Excel-Tabellen-Objekte --> Wordtabellen") = vbNo Then Exit Sub
Set oDoc = ActiveDocument
'Shape-Objekte vom letzten zum 1. prüfen
For iCount = oDoc.Shapes.Count To 1 Step -1
Set oShape = oDoc.Shapes(iCount)
'Shape-Typ prüfen
If oShape.Type = msoEmbeddedOLEObject Then
'OLE-Format-Programm-ID prüfen
If Left(oShape.OLEFormat.ProgID, 11) = "Excel.Sheet" Then
'Position des Ankerpunkt des Excel-Objektes merken
Set rngPosition = oShape.Anchor.Paragraphs(1).Range
'Excel-Objekt in Excel zum bearbeiten öffnen
oShape.OLEFormat.DoVerb VerbIndex:=1
'Excelanwendung einem Objekt zuweisen
Set xlApp = VBA.GetObject(, "Excel.Application")
'Aktive Arbeitsmappe (= Wordobjekt) bearbeiten
With xlApp.ActiveWorkbook.Worksheets(1)
'Bereich mit Daten ermitteln - erforderlich, da UsedRange hier Probleme _
machte wegen "unglücklicher" Zeilenformatierungen im Objekt
LastRow = 1
LastColumn = 1
'Letzte Spalte mit Daten ermitteln
For Zeile = .Cells.SpecialCells(11).Row To 1 Step -1
Spalte = .Cells(Zeile, .Columns.Count).End(-4159).Column '-4159=xlToLeft
If Spalte > LastColumn Then
LastColumn = Spalte
End If
Next
'Letzte Zeile mit Daten ermitteln
For Spalte = .Cells.SpecialCells(11).Column To 1 Step -1
Zeile = .Cells(.Rows.Count, Spalte).End(-4162).Row '-4162=xlUp
If Zeile > LastRow Then
LastRow = Zeile
End If
Next
'Datenbereich kopieren
.Range(.Cells(1, 1), .Cells(LastRow, LastColumn)).Copy
End With
Application.Activate 'zurück nach Word
'Einfügeposition selektieren
With rngPosition
oDoc.Range(.Start).Select
Selection.Collapse
End With
'Datenbereich aus Excel einfügen
' Selection.PasteExcelTable Linkedtoexcel:=False, Wordformatting:=False, _
RTF:=False 'Einfügen im HTML-Format
' Selection.PasteExcelTable Linkedtoexcel:=False, Wordformatting:=False, _
RTF:=True 'Einfügen im RTF-Format
Selection.PasteAndFormat (16) 'wdFormatOriginalFormatting
'Excel-Objekt in Excel schließen
xlApp.ActiveWorkbook.Close
oShape.Delete 'Excelobjekt in Word löschen
End If
End If
Next
Set xlApp = Nothing: Set oDoc = Nothing
Set rngPosition = Nothing: Set oShape = Nothing
End Sub