Office: [EXCEL 2003] - VBA - Automatisiert Bilder einfürgen ber VBA

Hallo leibe Forumsgemeinde,


ich habe in einer Excel-Datei, die hier so schlummerte, folgenden VBA-Code entdeckt:

PHP:

Option Explicit
Public Sub Bilder_einfuegen()
    Dim strPfadDatei As String
    Dim lngLetzteZeile As Long
    Dim wksBlatt As Worksheet
    Dim blnFrage As Boolean
    Dim picBild As Picture
    Const DateiPfad = "U:\USER\ETIK\DATENSICH\aktuell\GRAFIKEN_Neu\JPG-Dateien\"
    Set wksBlatt = ThisWorkbook.Worksheets("Tabelle1")
    On Error GoTo Ende
    Select Case MsgBox("Höhe 40 - ""Ja"" klicken! Breite 60 - ""Nein"" klicken!", _ 
       vbYesNo Or vbQuestion Or vbDefaultButton1, "Höhe Breite")
        Case vbYes
            blnFrage = True
        Case vbNo 
           blnFrage = False
    End Select
    Application.ScreenUpdating = False
    With wksBlatt
        lngLetzteZeile = .Range("C" & .Rows.Count).End(xlUp).Row
        For lngLetzteZeile = 2 To lngLetzteZeile
            If Dir(DateiPfad & .Range("C" & lngLetzteZeile).Text) <> "" Then
                Set picBild = .Pictures.Insert _ 
                   (DateiPfad & .Cells(lngLetzteZeile, 3).Text)
                With picBild.ShapeRange
                    .Top = wksBlatt.Range("D" & lngLetzteZeile).Top
                    .Left = wksBlatt.Range("D" & lngLetzteZeile).Left 
                   .LockAspectRatio = True
                    If blnFrage = True Then 
                       wksBlatt.Range("D" & lngLetzteZeile).RowHeight = 40
                        .Height = 40
                    Else
                        .Width = 60
                        wksBlatt.Range("D" & lngLetzteZeile).RowHeight = .Height
                    End If 
               End With
            End If 
       Next lngLetzteZeile
    End WithEnde:
    Application.ScreenUpdating = TrueEnd Sub


In besagter Datei stand in Spalte "C" der Name einer eizufügenden Grafik. Diese Grafik wurde in Spalte "D" entweder mit einer Höhe von 100 oder einer Breite von 60 eingefügt. Das klappt auch super in dieser einen Datei.


Ich möchte nun den Code so ändern, dass ich ihn auch in anderen Dateien nutzen kann.


Hierfür habe ich folgende Zeilen des Codes angepasst:

PHP:

    Set wksBlatt = ThisWorkbook.Worksheets("Tabelle1")


Hier habe ich den richtigen Pfad eingetragen

PHP:

  If Dir(DateiPfad & .Range("C" & lngLetzteZeile).Text) <> "" Then
      Set picBild = .Pictures.Insert _
          (DateiPfad & .Cells(lngLetzteZeile, 3).Text)


In diesem Teil habe ich "C" durch "W" ersetzt, weil der Dateiname nun in Spalte "W" steht.

PHP:

  .Top = wksBlatt.Range("D" & lngLetzteZeile).Top
  .Left = wksBlatt.Range("D" & lngLetzteZeile).Left
  .LockAspectRatio = True  If blnFrage = True Then
      wksBlatt.Range("D" & lngLetzteZeile).RowHeight = 40
      .Height = 40
  Else
      .Width = 60
      wksBlatt.Range("D" & lngLetzteZeile).RowHeight = .Height  
End If


Das "D" habe ich durch "M" ersetzt, damit die Grafik in Spalte "M" eingefügt wird.


Leider passiert beim Ausführen des Macros mal so gar nichts…


Könnt Ihr mir vielleicht auf die Sprünge helfen?


Danke im Voraus,


Euer phyton2706

 

Hallo Phyton2706,

teste einmal mit folgender Änderung:

PHP:

Option Explicit
Public Sub Bilder_einfuegen()
    Dim strPfadDatei As String
    Dim lngLetzteZeile As Long
    Dim wksBlatt As Worksheet
    Dim blnFrage As Boolean
    Dim picBild As Picture
    Const DateiPfad = "U:\USER\ETIK\DATENSICH\aktuell\GRAFIKEN_Neu\JPG-Dateien\"
    Set wksBlatt = ThisWorkbook.Worksheets("Tabelle1")
    On Error GoTo Ende
    Select Case MsgBox("Höhe 40 - ""Ja"" klicken! Breite 60 - ""Nein"" klicken!", _
       vbYesNo Or vbQuestion Or vbDefaultButton1, "Höhe Breite")
        Case vbYes
            blnFrage = True
        Case vbNo
           blnFrage = False
    End Select
    Application.ScreenUpdating = False
    With wksBlatt
        lngLetzteZeile = .Range("W" & .Rows.Count).End(xlUp).Row
        For lngLetzteZeile = 2 To lngLetzteZeile
            If Dir(DateiPfad & .Range("W" & lngLetzteZeile).Text) <> "" Then
                Set picBild = .Pictures.Insert _
                   (DateiPfad & .Range("W" & lngLetzteZeile).Text)
                With picBild.ShapeRange
                    .Top = wksBlatt.Range("M" & lngLetzteZeile).Top
                    .Left = wksBlatt.Range("M" & lngLetzteZeile).Left
                   .LockAspectRatio = True
                    If blnFrage = True Then
                       wksBlatt.Range("M" & lngLetzteZeile).RowHeight = 40
                        .Height = 40
                    Else
                        .Width = 60
                        wksBlatt.Range("M" & lngLetzteZeile).RowHeight = .Height
                    End If
               End With
            End If
       Next lngLetzteZeile
  End With
Ende:
  Application.ScreenUpdating = True
End Sub


 

Hallo phyton2706,

ohne Deine Datei zu kennen vermute ich den Fehler in den obigen Zeilen.
Dort hängst Du den Zellinhalt hinter den Ordnerpfad, und verwendest dies dann als Dateiname.

Steht in den Zellen Deiner Mappe "Bild1.jpg" oder nur "Bild1" ???

Denn wenn die Dateiendung in der Zelle nicht mit drinn steht, können obige Zeilen nicht funktionieren.
Dann müssten entweder die Endungen mit in die Zellen oder mit in den Code rein.

 

Hallo Achim,

wenn es vorher lief und es wurden die Dateiangaben jetzt genau so eingetragen(mit Dateiendung .jpg), lag der Fehler wohl in dieser Zeile.

lngLetzteZeile = .Range("C" & .Rows.Count).End(xlUp).Row

statt

lngLetzteZeile = .Range("W" & .Rows.Count).End(xlUp).Row

somit wurde die Letzte Zeile falsch übergeben.

Es ist immer ein stochern im Heuhaufen, wenn der Code nicht komplett zur Verfügung gestellt wird, so wie er geändert wurde und sonstige Angaben Lückenhaft sind.

 

Hallo,

Thema wird hier auch schon ausführlich behandelt...
http://www.ms-office-forum.de/forum/showthread.php?t=287179