Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Farbe einer Markierung in einem bestimmten Bereich ändern.
#1
Photo 
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!
Antworten Top
#2
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?
Viele Grüße
Klaus-Dieter
Der Erfolg hat viele Väter, 
der Misserfolg ist ein Waisenkind
Richard Cobden
[-] Folgende(r) 1 Nutzer sagt Danke an Klaus-Dieter für diesen Beitrag:
  • khenschel
Antworten Top
#3
Hallo,

meine Frage hat sich beantwortet, nachdem ich das Bildchen angesehen habe. Mit Beispieldatei wäre das nicht passiert.
Viele Grüße
Klaus-Dieter
Der Erfolg hat viele Väter, 
der Misserfolg ist ein Waisenkind
Richard Cobden
Antworten Top
#4
Hallo Klaus-Dieter,

perfekt! Recht herzlichen Dank!

LG

Klaus-Dieter  19
Antworten Top
#5
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 !
Zum übersetzen von Excel Formeln:

http://dolf.trieschnigg.nl/excel/index.p...gids=en+de
Antworten Top
#6
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
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste