VBA Bild mit Zellbezug einfügen nach Bedingung

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub grafik_einfügen() Dim pfad As String Dim Symb As String Dim pic As Object pfad = "I:\Pfad\" 'Deinen Pfad eintragen For Each zelle In Range("B2:B6") Select Case zelle.Value 'konkrete Auswahl Case 1 Symb = "Ausrufezeichen.png" Case 2 Symb = "Haken.png" Case 3 Symb = "Kreuz.png" Case Else MsgBox "Nix vorgesehen" Exit Sub End Select zelle.Offset(0, 1).Select 'Zelle wählen (hat bei dir gefehlt) ActiveSheet.Pictures.Insert pfad & Symb 'einfügen gewünschtes Bild Set pic = ActiveSheet.Shapes(Shapes.Count) 'Bild als Objekt setzen Pic_resize pic, 1, Rows(zelle.Row).RowHeight, , zelle.Offset(0, 1).Left + 30 'Größe und Position festlegen durch Subroutine Next zelle End Sub

Sub Pic_resize(pic As Object, Seitenverh_sperr As Boolean, Optional höhe As Long, Optional Breite As Long, Optional Pos_li As Long) With pic .LockAspectRatio = Seitenverh_sperr If höhe > 0 Then .Height = höhe If Breite > 0 Then .Width = Breite .Left = Pos_li End With End Sub

Sub grafik_einfügen() Dim pfad As String Dim Symb As String Dim ws As Worksheet Dim pic As Object Set ws = Sheets("Dashboard") pfad = "I:\Pfad\" 'Deinen Pfad eintragen For shp = ws.Shapes.Count To 1 Step -1 ws.Shapes(shp).Delete Next shp For Each zelle In Worksheets("Tabelle1").Range("B2:B6") Select Case zelle.Value 'konkrete Auswahl Case 1 Symb = "Ausrufezeichen.png" Case 2 Symb = "Haken.png" Case 3 Symb = "Kreuz.png" Case Else MsgBox "Nix vorgesehen" Exit Sub End Select ws.Pictures.Insert pfad & Symb 'einfügen gewünschtes Bild Set pic = ws.Shapes(ws.Shapes.Count) 'Bild als Objekt setzen Pic_resize pic, 1, zelle.Height, , zelle.Top, Range("L" & zelle.Row).Left + 30 'Größe und Position festlegen durch Subroutine Next zelle End Sub

Sub Pic_resize(pic As Object, Seitenverh_sperr As Boolean, Optional höhe As Long, Optional Breite As Long, Optional Pos_vert As Long, Optional Pos_hori As Long) With pic .LockAspectRatio = Seitenverh_sperr If höhe > 0 Then .Height = höhe If Breite > 0 Then .Width = Breite If Pos_vert > 0 Then .Top = Pos_vert If Pos_hori > 0 Then .Left = Pos_hori .Placement = 1 End With End Sub

Moin!

Tja, ich kann ja nur sehen, was du auch zur Verfügung stellst...
Shapes sind grundsätzlich mit dem Sheet "verheiratet" nicht mit der Zelle. Daher müssten wir zur Identifikation von "Grafik in L" die .left -Position abfragen.

    For shp = ws.Shapes.Count To 1 Step -1

        If ws.Shapes(shp).Left >= ws.Range("L1").Left Then ws.Shapes(shp).Delete

    Next shp

Kann man eventuell auch das VBA so schreiben, dass er genau den Wert ausliest, von dem Namen der in Spalte A steht?
Klar geht das. Hab mich eh schon gefragt, warum immer alle gesetzt werden müssen.

Mit dem Worksheet_change-Ereignis wird schon TARGET als geänderte Zelle geliefert. Diese können wir als Parameter mit in die Sub Grafik einfügen geben.
Damit entfällt die Setzen-Schleife: es muss nur 1 Symbol ausgetauscht werden.

Denkansatz:
Zum Löschen muss ich alle Grafiken in ihrer Horizontalen u. Vertikalen Positon überprüfen. (Vergleichswert für die Zeile ist eigentlich unsauber, da ich voraussetze, das in Dashboard die gleiche Zeilenhöhe gesetzt ist wie in Tabelle 2)

    For shp = ws.Shapes.Count To 1 Step -1

        If ws.Shapes(shp).Left >= ws.Range("L1").Left And _

            ws.Shapes(shp).Top = Zelle.Top Then ws.Shapes(shp).Delete

    Next shp

Weiterentwicklung:
Wenn die Grafik zum Begriff gehört, dann benennen wir sie doch so!

    Set pic = ws.Pictures.Insert(pfad & Symb)  'einfügen gewünschtes Bild, setzen als object

    pic.Name = Zelle.Offset(, -1) 'Bild bekommt den namen aus Spalte "A"

Damit entfällt auch Schleife zum Löschen (musst die einmal von Hand löschen), da gezielt gelöscht werden kann.

Den Aufruf hab ich mit dem Parameter auch angepasst.:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("B2:B6")) Is Nothing Then grafik_einfügen Target

End Sub

Sub grafik_einfügen(Zelle As Range)



    Dim pfad As String

    Dim Symb As String

    Dim ws As Worksheet

    Dim pic As Object

    

    Set ws = Sheets("Dashboard")

    pfad = "I:\Pfad\" 'Deinen Pfad eintragen

    

    Pic_name = Zelle.Offset(, -1) 'Bild, das zu tauschen ist

    ws.Shapes(Pic_name).Delete

    

    Select Case Zelle.Value 'konkrete Auswahl

        Case 1

           Symb = "Ausrufezeichen.png"

        Case 2

           Symb = "Haken.png"

        Case 3

           Symb = "Kreuz.png"

        Case Else

            MsgBox "Nix vorgesehen"

            Exit Sub

    End Select

    

    Set pic = ws.Pictures.Insert(pfad & Symb)  'einfügen gewünschtes Bild, setzen als object

    pic.Name = Zelle.Offset(, -1) 'Bild bekommt den namen aus Spalte "A"

    Pic_resize pic, 1, Zelle.Height, , Zelle.Top, Range("L" & Zelle.Row).Left + 30 'Größe und Position festlegen durch Subroutine

End Sub

unverändert:

Sub Pic_resize(pic As Object, Seitenverh_sperr As Boolean, Optional höhe As Long, Optional Breite As Long, Optional Pos_vert As Long, Optional Pos_hori As Long)



    With pic

        .LockAspectRatio = Seitenverh_sperr

        If höhe > 0 Then .Height = höhe

        If Breite > 0 Then .Width = Breite

        If Pos_vert > 0 Then .Top = Pos_vert

        If Pos_hori > 0 Then .Left = Pos_hori

        .Placement = 1

    End With

End Sub

Gruß, MCO

Moin!

Ich versuch es mal schrittweise zu erklären.
Außerdem frag ich mich grad, woher er weiß, welchen Wert er aus Tabelle1 auslesen soll, um dann in Spalte L das richtige Symbol einzufügen.

Du schreibst "Tabelle1", ausgelesen und ausgelöst wird aber alles in Tabelle2. Diesen Code hasst du nicht übernommen:

Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Range("B2:B6")) Is Nothing Then grafik_einfügen Target

End Sub

Target wird in der Kopfzeile als Range deklariert und als Objekt mit an "grafik_einfügen" gegeben. Leider hast du auch da die Kopfzeile nicht ergänzt



Sub grafik_einfügen(Zelle As Range)



    Dim pfad As String

    Dim Symb As String

    Dim ws As Worksheet

    Dim pic As Object

    Dim Pic_name As String

...

...

...

"Zelle" ist die Zelle, die geändert wird, Offset beschreibe den Versatz zu dieser Zelle, also (1,0) ist 1 Zeile tiefer, (0,1) ist 1 Spalte rechts, (0,0) bring demnach keine Änderung, negativ beschreibt die Gegenrichtung.
Was auf deinem Zielsheet passiert, hat nichts mit dem Inhalt der Spalten A (bzw jetzt neu B) zu tun. Die Position (Zeile) der Grafiken ist abhängig von der Ursprungszeile. So gesehen bist du gezwungen, die Auflistung in der gleichen Reihenfolge zu halten wie in Tabelle2, da in der gleichen Zeile eingefügt wird.
Wenn du das anders haben willst, müssen wird den Begriff (aus Zelle.Offset(, -1) (die Null hab ich geschlabbert) im Sheet WS suchen.

Probiers mal aus.
https://www.herber.de/bbs/user/164324.xlsm

Gruß, MCO

Sub grafik_einfügen(Zelle As Range) Dim pfad As String Dim Symb As String Dim ws As Worksheet Dim pic As Object Dim pic_name As String Set ws = Sheets("Dashboard") pfad = "Pfad\" 'Deinen Pfad eintragen frag = Application.InputBox("ist das dein Pfad?", "Pfad", pfad) If frag = False Then Exit Sub 'pfad = "C:\temp\" 'Deinen Pfad eintragen pic_name = Cells(Zelle.Row, "B") & Zelle.Address(0, 0) 'Bild, das zu tauschen ist On Error Resume Next ws.Shapes(pic_name).Delete Select Case Zelle.Value 'konkrete Auswahl Case 1 Symb = "Ausrufezeichen.png" Case 2 Symb = "Haken.png" Case 3 Symb = "Kreuz.png" Case Else MsgBox "Nix vorgesehen", vbCritical Exit Sub End Select Select Case Zelle.Column 'geänderte spalte: einfügespalte bestimmen Case 48 'Spalte AV einf_sp = "L" Case 49 einf_sp = "M" Case 50 einf_sp = "N" Case Else MsgBox "Spalte nicht vorgesehen", vbCritical Exit Sub End Select Set pic = ws.Pictures.Insert(pfad & Symb) 'einfügen gewünschtes Bild, setzen als object pic.Name = Zelle.Offset(, -1) 'Bild bekommt den namen aus Spalte "A" Pic_resize pic, 1, Zelle.Height, , Zelle.Top, ws.Range(einf_sp & Zelle.Row).Left + 30 'Größe und Position festlegen durch Subroutine End Sub

Beliebteste Forumthreads (12 Monate)

VBA Bild mit Zellbezug einfügen nach Bedingung

19 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

19
Beiträge zum Forumthread

Beiträge zu diesem Forumthread