Große Diagrammsammlung katalogisieren

27/11/2009 - 22:57 von stefan schneider | Report spam
Hallo,

ich habe eine ziemlich große Sammlung an Dateien mit unterschiedlichen
Diagrammen. Diese habe ich grob in Ordner vorsortiert.

Dummerweise habe ich den Überblick verloren, welche Darstellungen ich habe.

ICh such nun nach einer Möglichkeit, z.B. per Makro jeweils alle Dateien
in einem Ordner nacheinander öffnen zu lassen, von allen enthaltenen
Diagrammen einen Screenshot u.à. zu machen und diese dann mit Angabe des
Dateinamens in Word einzufügen...

Geht sowas?

Danke

stefan
 

Lesen sie die antworten

#1 Andreas Killer
28/11/2009 - 13:03 | Warnen spam
stefan schneider schrieb:

ICh such nun nach einer Möglichkeit, z.B. per Makro jeweils alle Dateien
in einem Ordner nacheinander öffnen zu lassen, von allen enthaltenen
Diagrammen einen Screenshot u.à. zu machen und diese dann mit Angabe des
Dateinamens in Word einzufügen...

Geht sowas?


Jupp, làßt sich machen. Kopiere den Code in ein normales Modul und
speichere die Exceldatei in deinem Ordner ab. Dann rufst Du das Makro auf.

Andreas.

Sub AlleDateienDiagrammeNachWordKopieren()
Dim Pfad As String, FName As String
Dim WB As Workbook, WS, CO As ChartObject
Dim wObj As Object

'Word-Object holen oder erzeugen
On Error Resume Next
Set wObj = GetObject(, "Word.Application")
If Err <> 0 Then
Err.Clear
Set wObj = CreateObject("Word.Application")
End If
If Err <> 0 Then
MsgBox "Kann Word nicht öffnen. Abbruch."
Exit Sub
End If
On Error GoTo 0

'Neues Dokument erzeugen
wObj.Documents.Add
'Word anzeigen
wObj.Visible = True

Pfad = ThisWorkbook.Path & "\"
'Erste Datei suchen
FName = Dir(Pfad & "*.xls")
Do While FName <> ""
'Sind wir es?
If FName <> ThisWorkbook.Name Then
'Datei öffnen
Set WB = Workbooks.Open(Pfad & FName, False, True)
'Alle Blàtter durchlaufen
For Each WS In WB.Sheets
'Es ein Diagramm?
If TypeOf WS Is Chart Then
'Chart kopieren
WS.CopyPicture
'In Word einfügen
GoSub Copy2Word
Else
'Alle Diagramme im Blatt durchlaufen
For Each CO In WS.ChartObjects
'Chart kopieren
CO.Chart.CopyPicture
'In Word einfügen
GoSub Copy2Word
Next
End If
Next
'Datei schließen
WB.Close False
End If
'Nàchste Datei
FName = Dir
Loop
Exit Sub

Copy2Word:
With wObj.Selection
'Den Namen der Datei und Tabellennamen einfügen
.TypeText Text:=FName & ": " & WS.Name
'Enter
.TypeParagraph
'Chart einfügen
.Paste
'Enter
.TypeParagraph
End With
Return
End Sub

Ähnliche fragen