Bild aus Zelle kopieren

Sub Sortierung() Dim Teilname As String Dim Kategorienanzahl As Long Dim Text As String Text = Worksheets("Kartenerstellung").Range("B2") Kategorienanzahl = Worksheets("Datenbank").Cells(Rows.Count, 2).End(xlUp).Row For j = 4 To Kategorienanzahl Teilname = Worksheets("Datenbank").Cells(j, 2).Value Select Case True Case Text Like "*" & Teilname & "*" Sheets("Kartenerstellung").Range("C2").Value = Worksheets("Datenbank").Cells(j, 3).Value End Select Next j End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Micha,
bei den normalen Excel-Einstellungen wird beim Kopieren einer Zelle auch ein der Zelle befindliches Object mit kopiert und in der Zielzelle eingefügt - allerding werden dann auch Zellformate mit kopiert.
Diese Einstellung kann man in den Excel-Optionen ändern,
Wenn nur das Bild kopiert werden soll, dann wird es kompliziert.
Da du den Kopiervorgang wahrscheinlich öfter für die gleiche Zielzelle ausführen willst muss vor dem Kopieren ein vorhandenes altes Bild gelöscht werden.
Nachfolgend eine entsprechende Ergänzung zu deinem Makro wobei ich den Kopiervorgang in eine separate Sub ausgelagert habe, so ist es einfach in andere Mappen übertragbar.
Gruß
Franz

Sub Sortierung()
Dim Teilname As String
Dim Kategorienanzahl As Long
Dim Text As String
Dim j As Long
Dim bolFound As Boolean
Text = Worksheets("Kartenerstellung").Range("B2")
With Worksheets("Datenbank")
Kategorienanzahl = .Cells(.Rows.Count, 2).End(xlUp).Row
bolFound = False
For j = 4 To Kategorienanzahl
Teilname = .Cells(j, 2).Value
If Text Like "*" & Teilname & "*" Then
Sheets("Kartenerstellung").Range("C2").Value = .Cells(j, 3).Value
bolFound = True
Call prcCopyShapeObject(Ziel:=Sheets("Kartenerstellung").Range("C2"), _
Quelle:=.Cells(j, 3), TopLeft:=False)
Exit For
End If
Next j
End With
If bolFound = False Then
MsgBox "Kein Treffer zu Wert in B2 gefunden"
End If
End Sub
Public Sub prcCopyShapeObject(Ziel As Range, _
Quelle As Range, TopLeft As Boolean)
'bei TopLeft = True wird das Bild in der linken oberen Ecke der _
Zielzelle eingefügt
Dim objSh As Object
Dim TopDiff As Single
Dim LeftDiff As Single
'vorhandenes Bild in Zielzelle bzw. mit passendem Namen löschen
For Each objSh In Ziel.Parent.Shapes
If objSh.TopLeftCell = Quelle Then
objSh.Delete
Exit For
ElseIf objSh.Name = "Bild_" & Ziel.Address(False, False, xlA1) Then
objSh.Delete
Exit For
End If
Next
'Bild in Quelle suchen und nach Ziel kopieren
For Each objSh In Quelle.Parent.Shapes
'Prüfen, ob die obere linke Zelle des Bildes mit der Quellzelle übereinstimmt
If objSh.TopLeftCell = Quelle Then
With objSh
'Abstände des Bildes zur linken oberen Ecke der Quellzelle merken
TopDiff = .Top - Quelle.Top
LeftDiff = .Left - Quelle.Left
.Copy
End With
With Ziel.Parent
'kopiertes Bild einfügen
.Paste
'eigefügtes Bild (ist normalerweise das letzte Bild im Blatt) _
einer Variablen zuweisen
Set objSh = .Shapes(.Shapes.Count)
With objSh
'Name des eingefügten Bildes neu festlegen (zum Löschen beim _
nächsten Kopiervorgang)
.Name = "Bild_" & Ziel.Address(False, False, xlA1)
'Bild im Zielblatt positionieren
.Top = Ziel.Top + IIf(TopLeft, 0, TopDiff)
.Left = Ziel.Left + IIf(TopLeft, 0, LeftDiff)
End With
End With
Exit For
End If
Next
Ziel.Select
If objSh Is Nothing Then
MsgBox "Kein Bild gefunden"
End If
End Sub

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bild aus Zelle kopieren

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread