Farbe einer Markierung in einem bestimmten Bereich ändern.

[khenschel]

Hallo zusammen,

mit diesem Code wird in einer Tabelle, nach Doppelklick einer Zelle, ein transparenter, blauer Kreis als Markierung erzeugt.
Ich möchte, dass in einem definierten Bereich der Tabelle die Kreise z.B. grün sind - bei mir wäre das der Bereich ("K9":"O80").
Wie kann ich das realisieren? Ich dachte an eine If-Then-Else Bedingung?!

Hier der Code, der die Kreismarkierung in jeder Zelle erzeugt, die doppelt geklickt wird:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

  Dim shp As Shape
  Dim iAbst As Integer
 
  iAbst = 1    'Abstand zum seitl. Zellrand - bei Bedarf ändern
  Cancel = True
 
  '***Kreis löschen, wenn vorhandenen
  For Each shp In ActiveSheet.Shapes
    If shp.TopLeftCell.Address = Target.Address Then
      shp.Delete
      Exit Sub
    End If
  Next
  Application.ScreenUpdating = False    
 
  '***Kreis einfügen
  ActiveSheet.Shapes.AddShape(msoShapeOval, 0, 0, 20, 20).Select
 
  '***Kreis in aktive Zelle verschieben und anpassen
  With Selection.ShapeRange
    .Width = Target.Width - 2 * iAbst
    .Height = .Width
    .Top = Target.Top + (Target.Height - .Height) / 2
    .Left = Target.Left + iAbst
    .Fill.Visible = msoFalse
    .Line.ForeColor.RGB = RGB(0, 176, 240) 'Hellblau
    .Line.Weight = 2.25
  End With
  Target.Select
End Sub

Vielen Dank für eure Unterstützung!

[Klaus-Dieter]

Hallo,

so funktioniert das:

Code:

Option Explicit

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
   
    Dim shp As Shape
    Dim iAbst As Integer
    Dim lngFarbe As String          'KDO
    Dim intersectRange As Range     'KDO
    Set intersectRange = Application.Intersect(Target, Range("K9:O80"))     'KDO
    If Not intersectRange Is Nothing Then lngFarbe = 80 Else lngFarbe = 240 'KDO
    iAbst = 1    'Abstand zum seitl. Zellrand - bei Bedarf ändern
    Cancel = True
   
    '***Kreis löschen, wenn vorhandenen
    For Each shp In ActiveSheet.Shapes
        If shp.TopLeftCell.Address = Target.Address Then
            shp.Delete
            Exit Sub
        End If
    Next
    Application.ScreenUpdating = False
   
    '***Kreis einfügen
    ActiveSheet.Shapes.AddShape(msoShapeOval, 0, 0, 20, 20).Select
   
    '***Kreis in aktive Zelle verschieben und anpassen
    With Selection.ShapeRange
        .Width = Target.Width - 2 * iAbst
        .Height = .Width
        .Top = Target.Top + (Target.Height - .Height) / 2
        .Left = Target.Left + iAbst
        .Fill.Visible = msoFalse
        .Line.ForeColor.RGB = RGB(0, 176, lngFarbe)     'KDO
        .Line.Weight = 2.25
    End With
    Target.Select
End Sub

Das alle Kreise stehen bleiben, ist gewollt?

[Klaus-Dieter]

Hallo,

meine Frage hat sich beantwortet, nachdem ich das Bildchen angesehen habe. Mit Beispieldatei wäre das nicht passiert.

[khenschel]

Hallo Klaus-Dieter,

perfekt! Recht herzlichen Dank!

LG

Klaus-Dieter 

[snb]

Warum nicht ?

- pro Zeile ein Kreis erstellen ?
- jede Kreis invisible machen ?
- bei doppelclick:
   *  Kreis:  .Top = Target.top
   *  Kreis:  .Left = Target.left
   *  Kreis:  .visible = true

NB. Verzichte auf verbundenen Zellen !

[derHoepp]

Moin,

Wäre es nicht viel sinnvoller, Datenverarbeitung zu verwenden, als Bilder auf Druckblätter zu malen? Viel interessanter ist doch später, welcher Wert je Frage gewählt wurde, und ob sich der Wert über den Zeitablauf vielleicht verändert hat. Ich halte das Vorgehen für unsinnigen Schnickschnack.

Viele Grüße
derHöpp