Ecxel VBA- Bilder einfügen in Zelle

[Bjoern95]

Hallo,
ich bin neu hier da ich ein Problem habe mit Excel VBA.

Ich habe eine Tabelle, wo ich in einer Tabellenspalte Bilder einfügen will.
Dazu habe ich in die jeweiligen Zellen, Textfelder eingesetzt und den Textfeldern Makros zugeteilt.

Der Code ist:

Sub Makro_Bild_einfügen_1()
'
' Makro_Bild_einfügen Makro

Dim sPicture As String, pic As Picture

sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")

If sPicture = "False" Then Exit Sub

Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = Range("K13:L13").Height
.Width = Range("K13:L13").Width
.Top = Range("K13:L13").Top
.Left = Range("K13:L13").Left
.Placement = xlMoveAndSize
End With

Set pic = Nothing

End Sub

Funktioniert auch Super!
Man Klickt einfach auf das Textfeld in der Zelle dann öffnet sich das Fenster " select Picture to Import" dann wählt man das Bild aus und es wird automatisch in die Zelle eingefügt und auf die Zellengröße angepasst.


Jetzt meine Frage!!!: Gibt es eine Funktion/eine Schleife oder so was das ich den
Code auf die anderen Zellen übertragen kann? Also dass sich z.B.:  Top= Range ("K13:L13) in Top= Range ("K14:L14)
ändert.

Ich habe 900 Zellen die das Makro brauchen wenn ich das alles mit Hand ändern muss dann würde das eine Menge Arbeit bedeuten.

Ich hoffe ich habe mich Verständlich ausgedrückt und hoffe auf eure Antworten.

MfG

Björn

[Kuwer]

Hallo Björn,

vielleicht so:

Sub Makro_Bild_einfügen_1()
'
' Makro_Bild_einfügen Makro
Dim rngP As Range
Dim sPicture As String, pic As Picture

sPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.jpg; *.bmp; *.tif), *.gif; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")

If sPicture = "False" Then Exit Sub
Set rngP = ActiveSheet.Shapes(Application.Caller).TopLeftCell.Resize(1, 2)
Set pic = ActiveSheet.Pictures.Insert(sPicture)
With pic
.ShapeRange.LockAspectRatio = msoFalse
.Height = rngP.Height
.Width = rngP.Width
.Top = rngP.Top
.Left = rngP.Left
.Placement = xlMoveAndSize
End With

Set pic = Nothing

End Sub

Gruß Uwe

[Bjoern95]

Hallo Uwe,

funktioniert super vielen Dank

mfg