Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1372to1376
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Objekt auslesen und in andere Excaldatei kopieren

Objekt auslesen und in andere Excaldatei kopieren
12.08.2014 09:18:41
kathrin
Guten Morgen,
ich möchte gerne eine Grafik die in mehreren Exceldateien vorhanden ist auslesen und in eine andere bereits bestehende Exceldatei einfügen.
Die Grafik ist in allen Dateien der Grunddaten immer im Tabellenblatt Kalkulation Bereich Y4:AB8 abgelegt. Es besteht eine Datei zur Zusammenfassung, diese übernimmt bereits Werte aus den Grunddateien, um die wichtigsten Angaben eines Projekts auf einen Blick zu sehen.
Da es sich immer um mehrere verschiedene Teile handelt, wäre es super, wenn das Bild mit übernommen werden könnte und in einer bestimmten Zelle eingefügt werden würde.
Vielen Dank im Voraus für eure Hilfe und mal ein großes Lob an dieses Forum.
Ich habe hier super Unterstützung von vielen hilfsbereiten Mitgliedern erhalten.
Freundliche Grüße
Kathrin

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Objekt auslesen und in andere Excaldatei kopieren
12.08.2014 11:30:51
fcs
Hallo Katrin,
worum handelt es sich bei der Grafik? Diagramm, Form, Bild?
Was soll ausgelesen/kopiert werden?
Grundsätzlich kann man ein in eine Tabelle eingefügtes Objekt an Hand der Adresse der TopLeftCell ermittel und einer entsprechenden ObjektVariablen zuweisen. Aber was soll anschließend passieren?
Gruß
Franz

AW: Objekt auslesen und in andere Excaldatei kopieren
12.08.2014 12:19:14
kathrin
Hallo Franz,
es ist ein Bild eines Artikels, meist als Screenshot aufgenommen. Das Bild aus der Grunddatei soll kopiert werden und in die Zusammenfassung aufgenommen werden, die einen Überblick aller Artikel im Projekt darstellt.
Die Zusammenfassungsdatei, ließt aus allen Exceldateien, die mit ihr in einem Ordner abgelegt sind, bestimmte Werte zu jedem Artikel des Projekts aus, und kopiert diese Werte in eine Tabellenblatt der Zusammenfassungsdatei.
Super wäre jetzt wenn man das Bild zum passenden "Datensatz" mit einfügen könnte.
Gruß Kathrin

Anzeige
AW: Objekt auslesen und in andere Excaldatei kopieren
12.08.2014 12:40:14
fcs
Hallo Katrin,
hier ein Beispielmakro
Gruß
Franz
Sub aaTest()
Dim objShape As Shape
Dim wkbAktiv As Workbook
Set wkbAktiv = ActiveWorkbook
Set objShape = fncGetShapeObject(wkb:=Workbooks("Mappe3.xlsx"), strWks:="Kalkulation", _
strTopLeftCell:="Y4")
If Not objShape Is Nothing Then
With wkbAktiv.Worksheets("Tabelle2") 'Tabellenblatt in dem eingefügt werden soll
.Activate
.Range("B5").Select 'Zelle der linken oberen Ecke des Objekts nach dem Einfügen
objShape.Copy
.Paste
End With
End If
End Sub
Function fncGetShapeObject(wkb As Workbook, strWks As String, strTopLeftCell As String) As  _
Shape
'wkb = Arbeitsmappe aus der das Shape kopiert werden soll
'strWks = Name des Tabellenblatts auf dem sich das zu kopierende Shape befindet.
'strTopLeftCell = Adresse der Zelle in der sich die linke obere Ecke des Shape-Objekts  _
befindet
Dim objShape As Shape
For Each objShape In wkb.Worksheets(strWks).Shapes
If objShape.TopLeftCell.Address(False, False, xlA1) = strTopLeftCell Then
Set fncGetShapeObject = objShape
End If
Next
End Function

Anzeige
AW: Objekt auslesen und in andere Excaldatei kopieren
12.08.2014 13:35:28
kathrin
Hallo Franz,
habe es versucht. Zeigt immer Meldung: Index außerhalb des gültigen Bereiches.
Sagt dir das was?
Ich habe nur Mappe3.xlsm geändert in den Dateinamen den meine Datei hat mit .xls
Gruß Kathrin

AW: Objekt auslesen und in andere Excaldatei kopieren
12.08.2014 13:56:24
fcs
Hallo Kathrin,
die Datei aus der das Bild kopiert werden soll muss zum Zeitpunkt, wenn das Makro ausgeführt wird, schon geöffnet sein oder das Öffnen der Datei muss noch in das Makro integriert werden.
Ich war davon ausgegangen, dass die Quelldatei schon geöffnet ist, da du ja auch andere Daten aus der Datei in deine Übersicht überträgst. In dieses Makro müsstest du eigentlich das Kopieren der Bilder integrieren können.
Gruß
Franz

Anzeige
AW: Objekt auslesen und in andere Excaldatei kopieren
12.08.2014 14:25:01
kathrin
Hallo Franz,
erstmal vielen Dank für deine bisherige Hilfe.
Ich dachte nicht, dass sich das integrieren für mich als so schwer erweisen würde, als ich die Frage ins Forum stellte, da ich im letzten halben Jahr mich mehr mit Makros befasst habe und dachte mein Kenntnisstand würde ausreichen.
Doch ich habe jetzt leider keine Ahnung wo ich Teile deines Makros einbauen soll. Kannst du mir dabei noch helfen?
Die Zusammenfassungsdatei erkennt selbst wo sie liegt und die Namen der Dateien, die sie durchsuchen soll. Auf einem Tabellenblatt wird eingetragen aus welchem Tabellenblatt der Grunddaten welche Zelle übertragen werden soll. Ich vermute es müsste dort dazugefügt werden, was ich jetzt fett und kursiv hervorgehoben habe.
Option Explicit
Private wbZiel As Workbook
Private wksZiel As Worksheet
Private wksSteuer As Worksheet
Private Zeile As Long, sZelle As String, Spalte As Long
'#### Sub-Routine zum Auslesen von Dateinamen in einem Ordner, Optional inkl. Unter-Ordner
'Quelle: https://www.herber.de/forum/archiv/1064to1068/t1064122.htm#1064890
'Modifiziert: fcs 2010-08-07
Public plCount As Long, parrFiles() As String
Public Sub ListFilesInFolder(ByVal SourceFolderName As String, _
Optional DateiFormat As String = "*.*", _
Optional IncludeSubfolders As Boolean = False, _
Optional FolderName As Boolean = False)
'SourceFolderName   = Ordner, wo soll gesucht werden?
'DateiFormat        = Like-Vergleich für Dateinamen, * als Platzhalter verwenden, Optional -  _
leer ist alle
'IncludeSubfolders  = Unterordner mit durchsuchen - True = Ja , False = Nein, Optional
'FolderName         = Dateiname inkl. Pfad ausgeben -  True = Ja, False = Nein, Optional
'Erstellt gemäß Suchkriterien ein Array mit den Dateinamen - optional inkl. Pfad
Dim FSO As Object, SourceFolder As Object, SubFolder As Object
Dim FileItem
Set FSO = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = FSO.GetFolder(SourceFolderName)
On Error GoTo Err_Zugriff: 'sollte Ordner geschützt sein
'*******************************weitere Eigenschaften ********
'Name: FileItem.Name
'Pfad mit Dateiname: FileItem.Path
For Each FileItem In SourceFolder.Files
If LCase(FileItem.Name) Like LCase(DateiFormat) Then
plCount = plCount + 1
ReDim Preserve parrFiles(1 To plCount)
parrFiles(plCount) = IIf(FolderName, FileItem, FileItem.Name)
End If
Next FileItem
If IncludeSubfolders Then
For Each SubFolder In SourceFolder.SubFolders
ListFilesInFolder SubFolder.Path, DateiFormat, IncludeSubfolders, FolderName
Next SubFolder
End If
Err_Zugriff:
Set FileItem = Nothing: Set SourceFolder = Nothing: Set FSO = Nothing
End Sub

'### Zusammenfassung: Altdaten löschen, Daten aus den Dateien auslesen und in Zusammenfassung einfügen ###
Sub Zusammenfassung_Erstellen()
Dim strOrdner As String
Dim lFile As Long, StatusCalc As Long
Dim ZeileLetzte As Long
Dim lngZeile1 As Long
On Error GoTo Fehler
Set wksSteuer = ThisWorkbook.Worksheets("Steuerung")
'Zieldatei/-Tabellenblatt setzen
Set wbZiel = ThisWorkbook
Set wksZiel = wbZiel.Worksheets("Zusammenfassung") 'Name des Zielblatts ggf. anpassen
'1. Zeile in die Daten in der Zusammenfassung eingetragen werden
lngZeile1 = wksZiel.Range("Zeile_Daten_1").Row
'zu durchsuchendes Verzeichnis gleich dem Ordner dieser Datei setzen
strOrdner = wbZiel.Path
wksSteuer.Range("Verzeichnis") = strOrdner
StatusCalc = Application.Calculation 'Berechnungsmethode merken
'Altdaten unterhalb der Spaltentitel in Zieltabelle löschen
With wksZiel
'Letzte Datenzeile in Zusammenfassung in Spalte A
With .UsedRange
ZeileLetzte = .Row + .Rows.Count - 1
End With
If ZeileLetzte >= lngZeile1 Then
'Hyperlinks und Inhalte löschen
.Range(.Rows(lngZeile1), .Rows(ZeileLetzte)).ClearContents
End If
ZeileLetzte = lngZeile1 - 1
End With
'Dateiliste zurücksetzen
plCount = 0
Erase parrFiles
'Dateiliste erstellen
Call ListFilesInFolder(SourceFolderName:=strOrdner, _
DateiFormat:="*.xls*", _
IncludeSubfolders:=wksSteuer.Range("Unterverzeichnisse") = "Ja", _
FolderName:=True)
If plCount MsgBox "Keine Kalkulationsdateien im Verzeichnis """ & strOrdner & """ gefunden", _
vbInformation, "Z U S A M M E N F A S S U N G erstellen"
Else
'Makrobremsen lösen
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
'gefundene Dateien abarbeiten
For lFile = 1 To plCount
If fncCheckOeffnen(parrFiles(lFile)) = True Then
Application.StatusBar = "Bearbeite Datei " & lFile & " von " & plCount & "," _
& parrFiles(lFile)
ZeileLetzte = ZeileLetzte + 1
Call Daten_Auslesen(sFilename:=parrFiles(lFile), ZeileZiel:=ZeileLetzte)
End If
Next
'Summenzeile gemäß Vorgaben im Blatt Steuerung im Zielblatt einfügen
ZeileLetzte = ZeileLetzte + 2 'eine Leerzeile lassen
With wksSteuer
For Zeile = .Range("StartListe").Row + 1 To .Cells(.Rows.Count, 2).End(xlUp).Row
Spalte = .Cells(Zeile, 4).Value
sZelle = .Cells(Zeile, 5).Text
With wksZiel.Cells(ZeileLetzte, Spalte)
Select Case sZelle
Case ""
Case "Formel"
.FormulaR1C1 = "=SUM(R" & lngZeile1 & "C:R[-2]C)"
Case Else
.Value = sZelle
End Select
End With
Next
End With
'Druckbereich anpassen
With wksZiel
With wksZiel.Names("Print_Area").RefersToRange
Spalte = .Column + .Columns.Count - 1
sZelle = .Range("A1").Address & ":" & wksZiel.Cells(ZeileLetzte, Spalte).Address
End With
.PageSetup.PrintArea = sZelle
End With
With Application
.ScreenUpdating = True
.StatusBar = False
End With
MsgBox "Fertig", vbInformation, "Z U S A M M E N F A S S U N G erstellen"
wksZiel.Range("Zeit_Aktualisierung") = Now
wksZiel.Activate
End If
Err.Clear
'Fehlerbehandlung
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr: " & .Number & vbLf & .Description
End Select
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = StatusCalc
.StatusBar = False
End With
'Variablen aufräumen
'Dateiliste wieder entleeren
plCount = 0
Erase parrFiles
Set wbZiel = Nothing: Set wksZiel = Nothing: Set wksSteuer = Nothing
End Sub
Private Sub Daten_Auslesen(ByVal sFilename As String, ByVal ZeileZiel As Long)
Dim wbQuelle As Workbook
Dim sNameBlatt As String
'Datei mit Artikel-Kalkulation schreibgeschützt öffnen, ggf. inkl. Aktualisierung externer  _
Verknüpfungen
Set wbQuelle = Application.Workbooks.Open(Filename:=sFilename, _
UpdateLinks:=wksSteuer.Range("Verknuepfungen") = "Ja", _
ReadOnly:=True)
If wksSteuer.Range("Berechnen") = "Ja" Then Application.Calculate
'Name der Quelldatei in Zielblatt eintragen und Hyperlink einfügen
With wksZiel
'Hyperlink zu Datei einfügen
.Hyperlinks.Add Anchor:=.Cells(ZeileZiel, 1), Address:=wbQuelle.FullName, _
ScreenTip:=wbQuelle.Name
.Cells(ZeileZiel, 1) = wbQuelle.Name
End With
  'Zellen mit den Kalkulationsdaten gemäß Vorgaben im Blatt Steuerung auslesen und in  _
Zielblatt eintragen
With wksSteuer
For Zeile = .Range("StartListe").Row + 1 To .Cells(.Rows.Count, 2).End(xlUp).Row
sNameBlatt = .Cells(Zeile, 2).Text
sZelle = .Cells(Zeile, 3).Value
Spalte = .Cells(Zeile, 4).Value
If fncCheckSheet(varBlatt:=sNameBlatt, wb:=wbQuelle) = True Then
wksZiel.Cells(ZeileZiel, Spalte) = wbQuelle.Worksheets(sNameBlatt).Range(sZelle)
Else
MsgBox "Tabelle """ & sNameBlatt & """ ist in Datei """ & wbQuelle.Name & """ nicht  _
vorhanden!", _
vbInformation + vbOKOnly, "Prozedur: Daten_Auslesen"
End If
Next
End With
wbQuelle.Close savechanges:=False
Set wbQuelle = Nothing
End Sub

Private Function fncCheckOeffnen(ByVal strFile As String) As Boolean
'Prüfen, ob Datei strFile geöffnet werden darf
'Hier werden Ausnahmen festgelegt für Excel-Dateien, die bei der Erstellung der  _
Zusammenfassung nicht _
berücksichtig werden dürfen
Dim strDatei As String
fncCheckOeffnen = True
'Dateiname von Pfad\Dateiname abtrennen
strDatei = LCase(Mid(strFile, InStrRev(strFile, "\") + 1))
Select Case strDatei
Case LCase(ThisWorkbook.Name), "zusammenfassung.xls", "zusammenfassung.xlsm"
'Diese Dateien nicht in Zusammenfassung darstellen
fncCheckOeffnen = False
End Select
End Function

Public Function fncCheckSheet(ByVal varBlatt, Optional wb As Workbook) As Boolean
'Prüft ob Blatt in Arbeitsmappe vorhanden
Dim objSheet As Object
On Error GoTo Fehler
If wb Is Nothing Then Set wb = ActiveWorkbook
fncCheckSheet = True
Set objSheet = wb.Sheets(varBlatt)
Fehler:
With Err
Select Case .Number
Case 0 'Alles ok
Case Else
fncCheckSheet = False
End Select
End With
End Function

Anzeige
AW: Objekt auslesen und in andere Excaldatei kopieren
12.08.2014 14:42:42
kathrin
Hallo Franz,
habe gerade mal nachgeschaut. Du warst ja schon vor nem halben Jahr mein Helfer in der Not, der mir dieses tolle Makro zur Verfügung gestellt hat.
Danke nochmals.

318 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige