gleiche Bilder in vers. Zellen ansteuern

Hallo liebe Gemeinde,
ich komme mal wieder nicht weiter. Eine Beispieldatei habe ich angefügt:
https://www.herber.de/bbs/user/141999.xlsm
Zur Erklärung, diese Konstruktion brauche ich in vielen Zellen, also nicht nur wie im Beispiel 2 Zellen, sonst wäre es einfach.
Ich habe in einer Tabelle Zellen in denen jeweils 2 Bilder sind. Die Bildernamen sind jedoch immer gleich.
Einmal "x" und einmal "ok" jeweils in den Zellen.
Wenn ich eine aktive Zelle habe, so wie im Beispiel kann ich die Bilder mit Klick darin tauschen.
Klicke ich aber auf ein Bild in der nicht aktiven Zelle geht das logischerweise nicht, da ja die andere Zelle aktiv ist und die Bildernamen gleich sind und ich mich auf die ActiveCell... beziehe.
Wie kann ich durch den Klick auf die Grafik in der nicht aktiven Zelle, die darunter befindliche Zelle selektieren, ohne dass ich andere Grafik-Namen vergeben muss?
(Der Refresh-Button ist nur zum wieder einschalten beider Grafiken in der aktiven Zelle)
Vielleicht könnt Ihr mir helfen.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub x_ok_schalten() Dim NameBild As String Dim AShape As Shape NameBild = ActiveSheet.Shapes(Application.Caller).Name For Each AShape In ActiveSheet.Shapes If AShape.TopLeftCell.Address = ActiveSheet.Shapes(Application.Caller).TopLeftCell. _ Address Then With AShape If .Name = NameBild Then .Visible = False Else .Visible = True End If End With End If Next End Sub

Hallo Ralf,
hier eine Idee zu Deinem Anliegen.
Wie "betriebssicher" das ist, müsstest Du jetzt mal testen.

Code:
[Cc][+][-]

Option Explicit

Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
        lpPoint As POINTAPI) As Long

Type POINTAPI
  x As Long
  y As Long
End Type

Function GetShapeCell() As String
  Dim PT As POINTAPI, oShp As Object
  Dim x1 As Long, y1 As Long, x2 As Long, y2 As Long
  
  GetCursorPos PT
  For Each oShp In ActiveSheet.Shapes
      With ActiveWindow.ActivePane
          x1 = .PointsToScreenPixelsX(oShp.Left)
          y1 = .PointsToScreenPixelsY(oShp.Top)
          x2 = .PointsToScreenPixelsX(oShp.Left + oShp.Width)
          y2 = .PointsToScreenPixelsY(oShp.Top + oShp.Height)
          DoEvents
          If PT.x > x1 And PT.y > y1 And PT.x < x2 And PT.y < y2 Then
             GetShapeCell = oShp.TopLeftCell.Address
             Exit Function
          End If
      End With
  Next oShp
  
End Function

Sub x_ok_schalten()
 Dim T As String
 
 T = GetShapeCell()
 If T <> "" Then
    Range(T).Select
    MsgBox T
 End If
End Sub

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Beliebteste Forumthreads (12 Monate)

gleiche Bilder in vers. Zellen ansteuern

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

307 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

gleiche Bilder in vers. Zellen ansteuern

7 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)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread