1.1k Aufrufe
Gefragt in Tabellenkalkulation von
Hallo an alle,
auch ich habe ein Problem mit dem einfügen von Bildern in Excel.
Ich fand hier auf der Seite folgendes Makro, dass auch super funktioniert:

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

Pfad = "C:\\"
For Wiederholungen = 1 To ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
strDatnam = Pfad & Cells(Wiederholungen, 2).Value & ".jpg"
If Dir(strDatnam) <> "" Then
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Cells(Wiederholungen, 1).Left, Cells(Wiederholungen, 1).Top, 85, 85
Else
ActiveSheet.Cells(Wiederholungen, 1) = "Bild nicht vorhanden"
End If
Next

End Sub

Nun zu meiner Frage, in diesem Makro ist die Spalte "B" die Quelle des Dateinamens, bei mir müsste ich aber für verschiedene Tabellen gelegentlich die "Quelle" ändern. Das heist mal wäre es die Spalte A mal die Spalte C oder auch mal K.
Ich schaffe es zwar die "Zielspalte" in diesem Makro ohne weiteres zu ändern, aber leider gelingt es mir nicht die "Quellspalte" zu ändern.
Könnte mir bitte jemand erklären wie ich dieses in diesem Makro mache um flexibler zu sein.

Im vorraus schon mal vielen Dank!

Gruß Alex

11 Antworten

0 Punkte
Beantwortet von
Hallo Alex :-)

An 2 Stellen ist die 2 positioniert,die für Spalte B steht ^^

Gruss Nighty
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Alex,

die Quellspalte wird hier festgelegt:
strDatnam = Pfad & Cells(Wiederholungen, 2).Value & ".jpg"

und zwar durch die 2, d.h. Spalte B.
Daneben musst du auch noch diese Zeile anpassen:
For Wiederholungen = 1 To ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row

da hier die letzte Zeile der Quellspalte ermittelt wird.

Ich habe dir mal eine Inputbox hinzugefügt, mit der die Quellspalte abgefragt wird:

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

strQSpalte = InputBox("Bitte die Quellspalte eingeben (z.B. a)", "Eingabe Quellspalte")

Pfad = "C:\Test\"
For Wiederholungen = 1 To ActiveSheet.Cells(Rows.Count, strQSpalte).End(xlUp).Row
strDatnam = Pfad & Cells(Wiederholungen, strQSpalte).Value & ".jpg"
If Dir(strDatnam) <> "" Then
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Cells(Wiederholungen, 1).Left, Cells(Wiederholungen, 1).Top, 85, 85
Else
ActiveSheet.Cells(Wiederholungen, 1) = "Bild nicht vorhanden"
End If
Next

End Sub


Gruß

M.O.
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo,

da war Nighty mal wieder schneller ;-).

Gruß
M.O.
0 Punkte
Beantwortet von
Hallo MO ^^

Unbeabsichtigt,dafür ist mein Kaffee kalt geworden,
drei Finger Tippsystem fordert seinen Tribut :-(

Gruss Nighty
0 Punkte
Beantwortet von
Super vielen Dank für die schnellen und hilfreichen Antworten! :)

Kann man solch eine Inputbox auch für den Ordnerpfad, die Zielspalte und die Bildgröße erstellen??
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Alex,

vieles ist mit VBA möglich ;-). Ich würde nur Bildhöhe oder Bildbreite abfragen und das Bild dann dem Seitenverhältnis entsprechend skaliert einfügen. Natürlich kann man auch beides abfragen. Was wäre dir lieber?

Gruß

M.O.
0 Punkte
Beantwortet von
Hallo, ich denke die Bildhöhe und dann entsprechend skalieren wäre in meinem Fall das beste.

Viele Grüße Alex
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Alex,

probiere mal den folgenden Code:

Sub Bilder_einfügen()
Dim Pfad As String
Dim strDatnam As String
Dim Wiederholungen As Long
Dim strQSpalte As String
Dim strZSpalte As String
Dim Fld As Object
Dim dblHoehe As Double
Dim dblBbreite As Double
Dim Bildbreite As Double
Dim Bildhoehe As Double
Dim meinBild

'Pfad für Bilder auswählen,
Set Fld = CreateObject("Shell.Application").BrowseForFolder(0, "Bild-Verzeichnis wählen", 16, 17)

If Not TypeName(Fld) = "Nothing" Then
Pfad = Fld.Self.Path
Else
'falls kein Pfad gewählt, dann Abbruch
MsgBox "Kein Pfad gewählt! Abbruch", 16, "Fehler"
Exit Sub
End If
'ggf. Slash beim Pfad ergänzen
If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"

'Abfrage der Quell- und Zielspalte; als Eingabe ist nur Text zulässing
strQSpalte = Application.InputBox(prompt:="Bitte die Quellspalte eingeben (z.B. a)", Title:="Eingabe Quellspalte", Type:=2)

strZSpalte = Application.InputBox(prompt:="Bitte die Zielspalte eingeben (z.B. a)", Title:="Eingabe Zielspalte", Type:=2)

'Abfrage der Bildhöhe, als Eingabe ist nur Zahl zulässig
dblHoehe = CDbl(Application.InputBox(prompt:="Bitte die Höhe des Bildes eingeben (in cm)", Title:="Eingabe Zielspalte", Type:=1))
'cm in Punkte umwandeln, 1 cm = 28,35 pt
dblHoehe = dblHoehe * 28.35

For Wiederholungen = 1 To ActiveSheet.Cells(Rows.Count, strQSpalte).End(xlUp).Row
strDatnam = Pfad & Cells(Wiederholungen, strQSpalte).Value & ".jpg"
'Bildhöhe und Bildbreite einlesen
Set meinBild = LoadPicture(strDatnam)
Bildbreite = meinBild.Width
Bildhoehe = meinBild.Height

If Dir(strDatnam) <> "" Then
'Bild einfügen
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Cells(Wiederholungen, strZSpalte).Left, Cells(Wiederholungen, strZSpalte).Top, dblHoehe * Bildbreite / Bildhoehe, dblHoehe
Else
ActiveSheet.Cells(Wiederholungen, strZSpalte) = "Bild nicht vorhanden"
End If
Next

End Sub


Gruß

M.O.
0 Punkte
Beantwortet von
Hallo M.O.,

das sieht ja schon Klasse aus! :D

Leider zeigt er mir an: Laufzeitfehler '53' Datei nicht gefunden.

In dem VBA wird in dem Block:

For Wiederholungen = 1 To ActiveSheet.Cells(Rows.Count, strQSpalte).End(xlUp).Row
strDatnam = Pfad & Cells(Wiederholungen, strQSpalte).Value & ".jpg"
'Bildhöhe und Bildbreite einlesen
Set meinBild = LoadPicture(strDatnam)
Bildbreite = meinBild.Width
Bildhoehe = meinBild.Height


die Zeile: Set meinBild=LoadPicture(strDatnam) farbig hinterlegt.

Könntest du das Problem noch beheben??

Vielen Dank schonmal. :)
0 Punkte
Beantwortet von m-o Profi (22.7k Punkte)
Hallo Alex,

der Fehler kommt, wenn das Bild nicht im Verzeichnis vorhanden ist. Vielleicht ist es auch nur ein Schreibfehler in der Zelle.

Hier das Makro mit angepasster Fehlerroutine (hatte ich vergessen zu ändern):
Sub Bilder_einfügen()
Dim Pfad As String
Dim strDatnam As String
Dim Wiederholungen As Long
Dim strQSpalte As String
Dim strZSpalte As String
Dim Fld As Object
Dim dblHoehe As Double
Dim dblBbreite As Double
Dim Bildbreite As Double
Dim Bildhoehe As Double
Dim meinBild

'Pfad für Bilder auswählen,
Set Fld = CreateObject("Shell.Application").BrowseForFolder(0, "Bild-Verzeichnis wählen", 16, 17)

If Not TypeName(Fld) = "Nothing" Then
Pfad = Fld.Self.Path
Else
'falls kein Pfad gewählt, dann Abbruch
MsgBox "Kein Pfad gewählt! Abbruch", 16, "Fehler"
Exit Sub
End If
'ggf. Slash beim Pfad ergänzen
If Right(Pfad, 1) <> "\" Then Pfad = Pfad & "\"

'Abfrage der Quell- und Zielspalte; als Eingabe ist nur Text zulässing
strQSpalte = Application.InputBox(prompt:="Bitte die Quellspalte eingeben (z.B. a)", Title:="Eingabe Quellspalte", Type:=2)

strZSpalte = Application.InputBox(prompt:="Bitte die Zielspalte eingeben (z.B. a)", Title:="Eingabe Zielspalte", Type:=2)

'Abfrage der Bildhöhe, als Eingabe ist nur Zahl zulässig
dblHoehe = CDbl(Application.InputBox(prompt:="Bitte die Höhe des Bildes eingeben (in cm)", Title:="Eingabe Zielspalte", Type:=1))
'cm in Punkte umwandeln, 1 cm = 28,35 pt
dblHoehe = dblHoehe * 28.35

For Wiederholungen = 1 To ActiveSheet.Cells(Rows.Count, strQSpalte).End(xlUp).Row
strDatnam = Pfad & Cells(Wiederholungen, strQSpalte).Value & ".jpg"

If Dir(strDatnam) <> "" Then
'Bildhöhe und Bildbreite einlesen
Set meinBild = LoadPicture(strDatnam)
Bildbreite = meinBild.Width
Bildhoehe = meinBild.Height
'Bild einfügen
ActiveSheet.Shapes.AddPicture strDatnam, msoFalse, msoTrue, Cells(Wiederholungen, strZSpalte).Left, Cells(Wiederholungen, strZSpalte).Top, dblHoehe * Bildbreite / Bildhoehe, dblHoehe
Else
ActiveSheet.Cells(Wiederholungen, strZSpalte) = "Bild nicht vorhanden"
End If
Next

End Sub


Gruß

M.O.
...