Bild Objekt übertragen
14.08.2014 12:02:12
kathrin
möchte ein bestehendes, funktionierendes Makro ergänzen, komme leider nicht weiter.
Dieses Makro erkennt selbständig wo die Datei und die auszulesenden Dateien abgelegt sind und überträgt Werte aus den auszulesenden Dateien in diese zusammenfassende Datei.
Mein Ziel ist, das auch ein Bild, das sich im Tabellenblatt "Kalkulation" Zelle Y4 der auszulesenden Dateien befindet, mit übertragen wird.
Alles was fett und kursiv ist habe ich eingefügt um dies zu bewirken. Es funktioniert leider nicht.
Erkennt jemand meine Fehler?
Vielen Dank für eure Hilfe.
Gruß Kathrin
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)
Set objShape = fncGetShapeObjekt(varBlatt:="Kalkulation", strTopLeftCell:="Y4")
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
With wksZiel
.Activate
.Cells(ZeileZiel, 139).Select
objShape.Copy
.Paste
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
Public Function fncGetShapeObjekt(ByVal varBlatt, strTopLeftCell As String, Optional wb As _
Workbook) As Boolean
'Prüft ob Blatt in Arbeitsmappe vorhanden
Dim objShape As Shape
On Error GoTo Fehler
For Each objShape In wbQuelle.Worksheet("Kalkulation").Shapes
If objShape.TopLeftCell.Address(False, False, xlA1) = strTopLeftCell Then
Set fncGetShapeObject(strTopLeftCell:="Y4") = objShape(varBlatt)
End If
Next
Fehler:
With Err
Select Case .Number
Case 0 'Alles ok
Case Else
fncCheckSheet = False
End Select
End With
End Function