Bilder in Excel in bestimmte Zelle aus Pfad einfügen - automatisch

Question

Hallo da draussen,

Ich suche schon den ganzen Morgen nach einer einfachen vielleicht mit makro basierende Lösung für mein Problem. Habe auch schon einiges gefunden, was aber alles irgendwie nicht so funktioniert wie es sollte...

Folgendes Problem:

Ich arbeite in einem kleinen Mercahndising shop und wir gehen von Zeit zu Zeit an Messen und Märkte. Dazu mache ich jeweils eine Sortimentsliste mit Bildern. Ich habe gehofft dass es eine schnelle und vielleicht nicht all zu schwere Lösung gibt um in der Spalte "A" pro Zeile jeweils das entsprechende Bild welches in einem Ordner abgespeichert ist und dessen Name ohne suffix (da ich verschiedene Formate habe) in der Zeile "B" aufgelistet ist, eingefügt wird. Diesen Vorgang natürlich bis zum letzten Eintrag auf der Liste.

Nun bin ich ja nicht so wahnsinnig versiert mit excel und den umfangreichen funktionen und habe mich in diesem Forum und noch diversen anderen Foren umgeschaut und dabei folgendes Makro gefunden:

Option Explicit

Sub Bilder_einfügen()
Dim Pfad As String, Wiederholungen As Long
On Error Resume Next
Pfad = "C:\"
For Wiederholungen = 2 To Range("A65536").End(xlUp).Row
Cells(Wiederholungen, 3).Activate
ActiveSheet.Pictures.Insert(Pfad & Cells(Wiederholungen, 1) & ".jpg").Select
Next
End Sub

Danke an dieser Stelle an Coros.

Dieses Makro funktioniert bei mir aber scheinbar nicht und ich weiss beim besten willen nicht an was das es liegt. habe den Pfad schon diverse Male überprüft mit Backslash abgeschlossen und auch ohne und natürlich auch die Bilder entsprechend im jpg format heruntergeladen. Ebenso hab ich mit den Angaben in den Zellen und Spalten rum Jongliert... alles ohne Erfolg.

Natürlich könnte ich jedes Bild einzeln in der Liste einfügen und so zum entsprechenden Ziel kommen, aber ich würde dies gerne so machen dass ich in Zukunft einfach die Angaben auf der Tabelle und die Bilder im Ordner Wechseln kann und dies dann auch alles automatisch geht wenn ich mal wieder ein anderes Sortiment zusammen stelle...

Kurz gesagt: Ich würde gerne Eine Liste machen wo ich in Spalte "A" das Bild einsetzte welche sich im angegebenen Pfad befindet und auf den Namen(ohne Suffix) in Zeile "B" hört... nett wäre auch wenn sich das Bild und die Zeile an ein "vorgegebenes" Format anpasst...

Ich hoffe dass ich das ganze nicht all zu kompliziert formuliert habe und danke euch bereits jetzt für Eure Hilfe... ich weiss Ihr seit alle sehr Versiert was diese ganze Excellsache anbelangt... im übrigen: ich benutze Excell 2010 auf der Arbeit.

Answer 1

Hallo,

wenn das gepostete Makro auch das Makro ist, mit dem du die Bilder einfügen willst, funktioniert das nicht, da bei dem Makro die Bildnamen in der Spalte A stehen müssen.

Probier mal das folgende Makro:

Sub Bilder_einfügen()
Dim Pfad As String
Dim strDatnam As String
Dim Wiederholungen As Long

'Pfad anpassen
Pfad = "C:\Bilder\"
'Spalte B ab Zeile 2 durchlaufen
For Wiederholungen = 2 To ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
'Namen der Bilder stehen in Spalte B - ohne Endung; Einlesen in Variable mit Pfadangaben
strDatnam = Pfad & Cells(Wiederholungen, 2).Value & ".jpg"
'Prüfen, ob Bilddatei im Verzeichnis existiert
If Dir(strDatnam) <> "" Then
'falls ja: Bilder werden in Spalte A eingefügt, Größe 3 x 3 cm
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Cells(Wiederholungen, 1).Left, Cells(Wiederholungen, 3).Top, 85, 85
Else
'falls nein, wird in Spalte A eine Fehlermeldung geschrieben
ActiveSheet.Cells(Wiederholungen, 1) = "Bild nicht gefunden"
End If
Next

End Sub

Gruß

M.O.

Answer 2

Hallo,

ich sehe gerade dass da noch ein Fehler drin ist:
statt

ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Cells(Wiederholungen, 1).Left, Cells(Wiederholungen, 3).Top, 85, 85

muss es

ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Cells(Wiederholungen, 1).Left, Cells(Wiederholungen, 1).Top, 85, 85

heißen.

Gruß

M.O.

Answer 3

Hallo M.O

Ich Danke dir recht Herzlich für deine schnelle und Tolle Hilfe. Das Makro funktioniert Tadellos. Eine kleine Frage hab ich nun aber doch noch: Durch das Einstellen der Grösse von 3x3cm werden nun einige Bilder verzerrt (gestaucht) dargestellt und eingefügt. Gibt es die Möglichkeit bei den Bildern das Seitenverhältnis beizubehalten und die Zelle drumrum anzupassen? Leider sind meine Bilder nicht Quadratisch...! Soll ich eine standardgrösse festlegen damit dies einfacher von der hand geht?

Vielen Dank noch einmal für deine Hilfe. Ich bin froh dass es solche Foren gibt!

es Grüsst

Torty

Answer 4

Hallo Torty,

anbei der geänderte Code. Hier werden die Bilder skaliert eingefügt und die Zeilenhöhe und Spaltebreite entsprechend angepasst:

Sub Bilder_einfügen()
Dim Pfad As String
Dim strDatnam As String
Dim Wiederholungen As Long
Dim Bildbreite As Long
Dim Bildhöhe As Long
Dim meinBild
Dim maxBildhöhe As Long

'Pfad anpassen
Pfad = "C:\Test\"
'Spalte B ab Zeile 2 durchlaufen
For Wiederholungen = 2 To ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
'Namen der Bilder stehen in Spalte B - ohne Endung; Einlesen in Variable mit Pfadangaben
strDatnam = Pfad & Cells(Wiederholungen, 2).Value & ".jpg"
'Prüfen, ob Bilddatei im Verzeichnis existiert
If Dir(strDatnam) <> "" Then
'falls ja, dann Bildhöhe und -breite einlesen
Set meinBild = LoadPicture(strDatnam)
Bildbreite = meinBild.Width
Bildhoehe = meinBild.Height

'Bild einfügen, 5 cm Breit - 1 cm = 28,35 pt - und Höhe entsprechend skaliert
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Cells(Wiederholungen, 1).Left, Cells(Wiederholungen, 1).Top, 141.75, 141.75 * Bildhoehe / Bildbreite
'maximale Bildhöhe ermitteln, für die Anpassung der Zeilenhöhe
If maxBildhöhe < 141.75 * Bildhoehe / Bildbreite Then maxBildhöhe = 141.75 * Bildhoehe / Bildbreite
Else
'falls nein, wird in Spalte A eine Fehlermeldung geschrieben
ActiveSheet.Cells(Wiederholungen, 1) = "Bild nicht gefunden"
End If
Next

'Zeilenhöhe anpassen
Rows("2:" & ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row).RowHeight = maxBildhöhe + 4

'Spaltenbreite anpassen
Columns("A:A").ColumnWidth = 35

End Sub

Gruß

M.O.

Answer 5

Hallo M.O.

Hat alles wunderbar geklappt, ich danke dir herzlich für deine Hilfe. Die Preis/Sortimentsliste steht und meine Artikel sind mit Bildern versehen.

Besten Dank für deine Geduld und deine Hilfe!

Torty

Answer 6

Hallo M.O. und alle Andern,

Danke noch einmal für die Hilfe und danke für die Geduld. Kann ich euch noch einmal um einen kleinen Gefallen bitten? Wie gesagt bin ich mit diesen Makros überhaupt nicht Sattelfest weshalb ich hier noch einmal schreibe. Gibt es evtl die Möglichkeit dass die Bilder aus dem Pfad welche ja jeztzzt oben links pro Zelle eingefügt werden zentriert sind? Vielleicht mit dem selben Makro welches zum einfügen ja so wunderbar geklappt hat?

Danke für die Hilfe

Torty

Answer 7

Hallo Torty,

schau mal, ob das geänderte Makro so funktioniert wie du willst:

Sub Bilder_einfügen()
Dim Pfad As String
Dim strDatnam As String
Dim Wiederholungen As Long
Dim Bildbreite As Single
Dim Bildhöhe As Single
Dim meinBild
Dim maxBildhöhe As Single
Dim Bild As Shape
Dim Zelle As Range

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Pfad anpassen
Pfad = "C:\Test\"
'Spalte B ab Zeile 2 durchlaufen
For Wiederholungen = 2 To ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
'Namen der Bilder stehen in Spalte B - ohne Endung; Einlesen in Variable mit Pfadangaben
strDatnam = Pfad & Cells(Wiederholungen, 2).Value & ".jpg"
'Prüfen, ob Bilddatei im Verzeichnis existiert
If Dir(strDatnam) <> "" Then
'falls ja, dann Bildhöhe und -breite einlesen
Set meinBild = LoadPicture(strDatnam)
Bildbreite = meinBild.Width
Bildhoehe = meinBild.Height

'Bild einfügen, 5 cm Breit - 1 cm = 28,35 pt - und Höhe entsprechend skaliert
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Cells(Wiederholungen, 1).Left, Cells(Wiederholungen, 1).Top, 141.75, 141.75 * Bildhoehe / Bildbreite
'maximale Bildhöhe ermitteln, für die Anpassung der Zeilenhöhe
If maxBildhöhe < 141.75 * Bildhoehe / Bildbreite Then maxBildhöhe = 141.75 * Bildhoehe / Bildbreite
Else
'falls nein, wird in Spalte A eine Fehlermeldung geschrieben
ActiveSheet.Cells(Wiederholungen, 1) = "Bild nicht gefunden"
End If
Next

'Zeilenhöhe anpassen
Rows("2:" & ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row).RowHeight = maxBildhöhe + 4

'Spaltenbreite anpassen
Columns("A:A").ColumnWidth = 35

'Alle Bilder im Blatt in Zelle zentrieren
For Each Bild In ActiveSheet.Shapes

With Bild.TopLeftCell
Set Zelle = Cells(.Row, .Column)
End With

Bild.Top = Zelle.Top + (Zelle.Height - Bild.Height) / 2
Bild.Left = Zelle.Left + (Zelle.Width - Bild.Width) / 2

Next

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 8

Hallo M.O.

Einfach nur Perfekt, ich danke dir. Klappt wunderbar! Vielen vielen Dank.

Wie machst du das nur? :-)

sehr dankbare Grüsse

Torty

Answer 9

Hallo Torty,

jahrelange Übung ;-).

Gruß

M.O.

Answer 10

Hallo M.O.

Das merkt man... darf ich dich noch einmal um etwas bitten, damit du nicht aus der Übung kommst? :-) Die nun eingefügten Bilder sind nun alle in der Mitte, dies passt perfekt... nun müsste ich aber die Grösse der Bilder in Spalte A noch anpassen... ich habe bilder in Spalte A und B. mit dem befehl "ein bild markieren dann ctrl und a" werden nun die bilder in Spalte A und B markiert müsste aber nur diese in Spalte A vergrössern... gibt es da auch ein Tipp wie man dies gewährleisten kann ohne alle bilder einzeln auszuwählen und so mit "shift" 550 Bilder abzuklappern? vielleicht auch da ein makro... ich habe zwar folgendes gefunden:

Sub ShapesMarkieren1()
Dim shShape As Shape
Dim loShapes As Long
ReDim arrShapes(0)
For Each shShape In ActiveSheet.Shapes
If shShape.Top > Rows(6).Top And shShape.BottomRightCell.Left < Columns(5).Left And _
shShape.BottomRightCell.Top < Rows(3001).Top Then
ReDim Preserve arrShapes(0 To loShapes)
arrShapes(loShapes) = shShape.Name
loShapes = loShapes + 1
End If
Next shShape
If arrShapes(UBound(arrShapes())) <> "" Then
ActiveSheet.Shapes.Range(arrShapes()).Select
End If
End Sub

aber dieses Makro markiert mir alle bilder im dokument...

Grüsse und danke für deine erneute Hilfe.

Torty