Bild in Zelle mit Bedingungen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Max,
Rechtklick auf den Tabellenreiter - Code anzeigen. Folgende Prozeduren einfügen:

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)

    Dim lngRow As Long
    Dim objRange As Range, objCell As Range

    Set objRange = Intersect(Target, Range(Cells(3, 3), Cells(Rows.Count, 7)))

    If Not objRange Is Nothing Then

        For Each objCell In objRange

            If objCell.Row <> lngRow Then

                lngRow = objCell.Row

                Select Case Check(lngRow)

                    Case 25

                        Call DeleteShape(lngRow)

                        Call Shapes("Grafik 5").Copy
                        DoEvents
                        Call Paste(Destination:=Cells(objCell.Row, 8))

                    Case 18

                        Call DeleteShape(lngRow)

                        Call Shapes("Grafik 4").Copy
                        DoEvents
                        Call Paste(Destination:=Cells(objCell.Row, 8))

                    Case 7

                        Call DeleteShape(lngRow)

                        Call Shapes("Grafik 3").Copy
                        DoEvents
                        Call Paste(Destination:=Cells(objCell.Row, 8))

                    Case 3

                        Call DeleteShape(lngRow)

                        Call Shapes("Grafik 2").Copy
                        DoEvents
                        Call Paste(Destination:=Cells(objCell.Row, 8))

                    Case 0

                        Call DeleteShape(lngRow)

                End Select
            End If
        Next

        Set objRange = Nothing

        ActiveCell.Select

    End If
End Sub

Private Function Check(ByVal pvlngRow As Long) As Long

    Dim lngColumn As Long

    For lngColumn = 3 To 7

        If Not IsEmpty(Cells(pvlngRow, lngColumn).Value) Then Check = Check + lngColumn

    Next
End Function

Public Sub DeleteShape(ByVal pvlngRow As Long)

    Dim objShape As Shape

    For Each objShape In Shapes

        If objShape.TopLeftCell.Row = pvlngRow Then

            Call objShape.Delete

            Exit For

        End If
    Next

    Set objShape = Nothing

End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Bild in Zelle mit Bedingungen

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread