Bilder dynamisch per vba kopieren

Hallo,
ich habe folgendes Problem, ich gebe in e8:e31 einen Text ein den er dann mit be8:be31 vergleichen soll und dann die zelle be8:be31 wo ein bild drauf liegt, die zelle kopiert und in c8:c31 einfügt. Jetzt habe ich folgenden Code gefunden der mir Bilder aus einem Ortner einfügt was auch sehr gut funktioniert, jedoch finde ich es besser wenn die Bilder in der Exceldatei in einem Tabellenblatt liegen und er sie von dort aus aus der zelle kopiert. Hierfür habe ich auch einen Code gefunden, dieser wenn er durchläuft die zellen be8:be31 wo der text drin steht der mit e8:e31 verglichen wird und dann wird be8:be31 mit dem bild das über der zelle liegt kopiert, allerdings doppelt.
Erster Code Bild aus Datei:

Sub BildFenster()
Dim picBild As Picture
Dim rngZelle As Range
Dim strFenster As String
Dim strDatei As String
For i = 8 To 31
strFenster = Cells(i, 5).Value
strDatei = strFenster & ".jpg"
Set rngZelle = Worksheets("angebot").Cells(i, 3)
If Cells(i, 5).Value  " " Then
Set picBild = Worksheets("angebot").Pictures.Insert("C:\users\marcel brandner\desktop\neuer  _
ordner\" & strDatei)
picBild.Top = rngZelle.Top
picBild.Left = rngZelle.Left
End If
Next
End Sub

zweiter Code der die zellen doppelt kopiert:

Sub aktBestandsDaten()
Dim Gesucht As Variant
Dim Gefunden As Variant
For i = 8 To 9
Gesucht = Sheets("Angebot").Cells(i, 5).Value
Gefunden = Sheets("Angebot").Cells(i, 57).Value
If Gesucht = Gefunden Then
Sheets("Angebot").Range(Cells(i, 57), Cells(i, 57)).Copy Destination:=Sheets(" _
Angebot").Range(Cells(i, 3), Cells(i, 3))
End If
Next
End Sub

Es ist bestimmt nur eine Kleinigkeit die ich ändern muss, ich komme einfach nicht drauf, hoffe mir kann jemand helfen.
Gruß
Dominik

Hi Dominik,

Sub aktBestandsDaten()
Dim shaShape As Shape
Dim rngSuche As Range
Dim i As Long
Application.ScreenUpdating = False
With Worksheets("Angebot")
lngLetzte = .Columns(5).Find(What:="*", SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious).Row
For i = 8 To lngLetzte
If .Cells(i, 5).Value  "" Then
If .Cells(i, 3)  .Cells(i, 5) Then
Set rngSuche = .Columns(57).Find(.Cells(i, 5).Value, _
lookat:=xlWhole, LookIn:=xlValues)
If Not rngSuche Is Nothing Then
For Each shaShape In .Shapes
If shaShape.TopLeftCell.Address = .Cells(i, 3).Address Then
shaShape.Delete
Application.Wait Now + TimeValue("00:00:01")
Exit For
End If
Next shaShape
rngSuche.Copy _
Destination:=.Cells(i, 3)
End If
End If
End If
Next i
End With
Application.ScreenUpdating = True
End Sub

Bilder dynamisch per vba kopieren

Forumthread: Bilder dynamisch per vba kopieren

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial