Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Bild Objekt übertragen

Betrifft: Bild Objekt übertragen von: kathrin
Geschrieben am: 14.08.2014 12:02:12

Hallo,

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

  

Betrifft: AW: Bild Objekt übertragen von: fcs
Geschrieben am: 14.08.2014 14:34:14

Hallo Kathrin,

du hättest ja noch im alten Thread weiter machen können.

Ich verstehe nicht, warum du die Function zum Finden des Shapes geändert hast. Diese solltest du eigentlich unverändert übernehmen. Oder fehlen irgendwelche Prüfungen, die deiner Meinung nach erforderlich sind?

Ich hab deine Makros jetzt mal so angepasst, wie es funktionieren müsste.
Es sind jetzt Prüfungen enthalten, ob das Blatt "Klakulation" in der Quelldatei existiert und ob der Variablen ein Shape zugeordnet wurde(=Bild gefunden wurde). So sollte kein Fehler auftretten, wenn Blatt oder Bild fehlt.

Gruß
Franz

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 = Nothing                                                'neu
  If fncCheckSheet(varBlatt:="Kalkulation", wb:=wbQuelle) = True Then   'neu
    Set objShape = fncGetShapeObjekt(wkb:=wbQuelle, strWks:="Kalkulation", _
       strTopLeftCell:="Y4") 'geändert
  End If                                                                'neu
  
  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 _
            & """ nichtvorhanden!", _
            vbInformation + vbOKOnly, "Prozedur: Daten_Auslesen"
      End If
    Next
  End With
  
  If Not objShape Is Nothing Then                                             'neu
    With wksZiel
      .Activate
      .Cells(ZeileZiel, 139).Select
      objShape.Copy
      .Paste
    End With
  End If                                                                      'neu
    
  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


'Original-Function - Parameter jetzt als ByVal, zusätzlich Ausstieg aus Schleife wenn Shape  _
gefunden
Function fncGetShapeObjekt(wkb As Workbook, ByVal strWks As String, _
      ByVal 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 fncGetShapeObjekt = objShape
          Exit For
        End If
      Next
End Function



  

Betrifft: AW: Bild Objekt übertragen von: kathrin
Geschrieben am: 14.08.2014 15:20:32

Hallo Franz,

hammer, wirklich super, funktioniert. Herzlichen und großen Dank.

habe nur was geändert, weil ich nicht wusste, wie ich es richtig integrieren konnte. Sonst steckt da nichts dahinter.


Jetzt käme schon meine nächste Frage, besteht die Möglichkeit den Bildern einen Namen zuzuordnen, und zwar entsprechend der Positionsnummer (diese steht im selben Tabellenblatt in Spalte M)im Projekt, um sie damit auf einem anderen Tabellenblatt in der selben Datei geordnet wieder aufrufen zu können?

Gruß Kathrin


  

Betrifft: AW: Bild Objekt übertragen von: fcs
Geschrieben am: 15.08.2014 13:02:54

Hallo Kathrin,

versuche es mit folgender Ergänzung im entsprechenden Abschnitt des Makros.

  If Not objShape Is Nothing Then                                             'neu
    With wksZiel
      .Activate
      With .Cells(ZeileZiel, 13)
            If .Text <> "" Then
                objShape.Name = "Pos " & .Text 'Bildname zuweisen aus Text in Spalte M
            Else
                objShape.Name = "Pos " & Format(ZeileZiel, "00000")
            End If
      End With
      .Cells(ZeileZiel, 139).Select
      objShape.Copy
      .Paste
    End With
  End If                                                                      'neu

Den Text "Pos " kannst du auch ändern/weglassen. Wenn der Inhalt in Spalte M nur aus Ziffern und Punkten besteht, dann solltest du beim Namen der Bilder einen fixen Text voranstellen.

Gruß
Franz


  

Betrifft: AW: Bild Objekt übertragen von: kathrin
Geschrieben am: 15.08.2014 15:43:24

Hallo Franz,

du bist großartig. Tausend Dank.

Jetzt fehlt nur noch ne Kleinigkeit, aber damit beschäftige ich mich erst nächste Woche.

Wünsche dir ein schönes Wochenende.

freundliche Grüße
Kathrin


 

Beiträge aus den Excel-Beispielen zum Thema "Bild Objekt übertragen"