Prüfen, ob Autoform bereits in Zelle vorhanden ist

Bild

Betrifft: Prüfen, ob Autoform bereits in Zelle vorhanden ist
von: timo_100
Geschrieben am: 08.08.2015 18:19:23

Hallo zusammen,
Ich verwende ein Makro, das bei bestimmter Auswahl aus einer Drop-Down-Liste eine Raute in die Zelle hinzufügt. Problem ist bisher jedoch, dass die Raute bei erneuter Makroausführung nochmals eingefügt wird und die bestehende dann überlagert. Hab es dann mal mit "If Nothing" probiert, jedoch führt dies dazu, dass bei Makro-Aufruf gar keine Rauten mehr eingefügt werde..
Hat jemand eine Idee, die weiterhelfen könnte?
Vielen Dank.

Sub Test()
  
  Dim r As Range, s As Shape
  For Each r In Range("I9:DX644").SpecialCells(xlCellTypeConstants)
  If r.Value = "a" Or r.Value = "b" Or r.Value = "c" Then
    Set s = ActiveSheet.Shapes.AddShape(msoShapeDiamond, 180.25, 46.5, 18, 12.75)
 
    If s Is Nothing Then
    
    With s
      .Width = r.Width
      .Left = r.Left
      .Height = r.Height
      .Top = r.Top
      .Fill.Visible = False
     End With
    
    End If
     
   End If
  Next
End Sub


Danke und viele Grüße,
Timo

Bild

Betrifft: AW: Prüfen, ob Autoform bereits in Zelle vorhanden ist
von: Sepp
Geschrieben am: 08.08.2015 18:23:45
Hallo Timo,
vergib den Shapes einen Namen, der die Zelladresse enthält, dann kannst du ein evtl. schon vorhandenes Shape löschen, oder du prüfst bei allen Shapes auf dem Blatt, ob .TopleftCell auf die entsprechende Zelle verweist.

Gruß Sepp


Bild

Betrifft: AW: Prüfen, ob Autoform bereits in Zelle vorhanden ist
von: timo_100
Geschrieben am: 08.08.2015 20:16:34
Hallo Sepp,
vielen Dank für die Hinweise. Ich bin aber leider nicht so ganz zurechtgekommen. Also grundsätzlich verwende ich nur die Raute als einzigste Autoform.
Ich habe mal Folgendes probiert, da in J9 bereits eine Raute vorhanden ist:

Sub Test()
  
  Dim r As Range, s As Shape
  Dim shexist As Boolean
  
  ActiveSheet.Shapes(1).Name = "$J$9"
  
  For Each s In Worksheets("aa").Shapes
    If s.TopLeftCell.Address = "$J$9" Then
        shexist = True
        Exit For
    End If
  Next s
  
  
  If shexist Then
  Else
    
    For Each r In Range("I9:DX644").SpecialCells(xlCellTypeConstants)
    If r.Value = "a" Or r.Value = "b" Or r.Value = "c" Then
      
      Set s = ActiveSheet.Shapes.AddShape(msoShapeDiamond, 180.25, 46.5, 18, 12.75)
     
      With s
        .Width = r.Width
        .Left = r.Left
        .Height = r.Height
        .Top = r.Top
        .Fill.Visible = False
       End With
       
      End If
    Next
 End If
End Sub


Bild

Betrifft: AW: Prüfen, ob Autoform bereits in Zelle vorhanden ist
von: Sepp
Geschrieben am: 08.08.2015 20:30:02
Hallo Timo,
du musst schon jedem Shape einen eigenen Namen geben.

Sub shapes()
Dim rng As Range, objShp As Shape

For Each rng In Range("A1:E10").SpecialCells(xlCellTypeConstants) 'I9:DX644
  Set objShp = Nothing
  On Error Resume Next
  Set objShp = ActiveSheet.shapes("shape_" & rng.Address(0, 0))
  Err.Clear
  On Error GoTo 0
  If rng.Value = "a" Or rng.Value = "b" Or rng.Value = "c" Then
    If objShp Is Nothing Then
      Set objShp = ActiveSheet.shapes.AddShape(msoShapeDiamond, 0, 0, 1, 1)
      With objShp
        .Name = "shape_" & rng.Address(0, 0)
        .Width = rng.Width
        .Left = rng.Left
        .Height = rng.Height
        .Top = rng.Top
        .Fill.Visible = False
      End With
    End If
  Else
    If Not objShp Is Nothing Then objShp.Delete
  End If
Next

End Sub


Gruß Sepp


Bild

Betrifft: AW: Prüfen, ob Autoform bereits in Zelle vorhanden ist
von: timo_100
Geschrieben am: 08.08.2015 22:32:47
Hallo Sepp,
herzlichen Dank, das funktioniert super! :)
Ich habe nun noch überlegt, das ganze ohne Makroausführung zu machen. Also mit einem Worksheet_Change Ereignis. Das macht das Tool zwar etwas langsam, aber aus meiner Sicht erstmal noch akzeptabel.
Wenn ich hierbei in meiner Drop-Down-Liste nun einen der Werte ersetze, der nicht in r.Value festgelegt wurde (also z.B. „a“ durch „d“) verschwindet die Raute erwartungsgemäß. Wenn ich ein leeres Listenfeld aus dem Drop-Down-Menü auswähle, bleibt es jedoch.
Hast du vielleicht noch eine Idee, was ich hierbei noch ändern müsste?

Bild

Betrifft: AW: Prüfen, ob Autoform bereits in Zelle vorhanden ist
von: Sepp
Geschrieben am: 08.08.2015 22:39:25
Hallo Timo,
das ist logisch, weil du mit .SpecialCells(xlCellTypeConstants) nur Zellen mit Fix-Werten bearbeitest.

Gruß Sepp


Bild

Betrifft: AW: Prüfen, ob Autoform bereits in Zelle vorhanden ist
von: timo_100
Geschrieben am: 08.08.2015 22:47:19
Hallo Sepp,
ok, danke. Dann nehme ich einfach die 0 für die Leerzeile und lasse die Nullwerte nicht anzeigen..

Bild

Betrifft: AW: Prüfen, ob Autoform bereits in Zelle vorhanden ist
von: Sepp
Geschrieben am: 08.08.2015 23:17:44
Hallo Timo,
wenn du das Change-Ereignis verwendest, brauchst du doch nicht jedesmal de gesamten Bereich bearbeiten!

Gruß Sepp


Bild

Betrifft: AW: Prüfen, ob Autoform bereits in Zelle vorhanden ist
von: timo_100
Geschrieben am: 09.08.2015 12:28:46
Hallo Sepp,
wie meinst du das? Der Prüfbereich muss doch festgelegt werden?
Gruß Timo

Bild

Betrifft: AW: Prüfen, ob Autoform bereits in Zelle vorhanden ist
von: Sepp
Geschrieben am: 09.08.2015 12:38:05
Hallo Timo,
klar muss man den Bereich prüfen, aber nur die Zellen, in denen sich auch tatsächlich etwas verändert hat.

' **********************************************************************
' Modul: Tabelle2 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, objShp As Shape

If Not Intersect(Target, Range("I9:DX644")) Is Nothing Then
  For Each rng In Intersect(Target, Range("I9:DX644"))
    If Not rng.HasFormula Then
      Set objShp = Nothing
      On Error Resume Next
      Set objShp = Me.Shapes("shape_" & rng.Address(0, 0))
      Err.Clear
      On Error GoTo 0
      If IsNumeric(Application.Match(rng, Array("a", "b", "c"), 0)) Then
        If objShp Is Nothing Then
          Set objShp = Me.Shapes.AddShape(msoShapeDiamond, 0, 0, 1, 1)
          With objShp
            .Name = "shape_" & rng.Address(0, 0)
            .Width = rng.Width
            .Left = rng.Left
            .Height = rng.Height
            .Top = rng.Top
            .Fill.Visible = False
          End With
        End If
      Else
        If Not objShp Is Nothing Then objShp.Delete
      End If
    End If
  Next
End If
End Sub


Gruß Sepp


Bild

Betrifft: AW: Prüfen, ob Autoform bereits in Zelle vorhanden ist
von: timo_100
Geschrieben am: 09.08.2015 13:29:22
Hallo Sepp,
danke! Die Befehle werde ich mir auf jeden Fall genauer anschauen!
Nun läuft es flüssiger. :-)
Gruß Timo

Bild

Betrifft: Kürzer!
von: Sepp
Geschrieben am: 09.08.2015 12:50:15

' **********************************************************************
' Modul: Tabelle2 Typ: Element der Mappe(Sheet, Workbook, ...)
' **********************************************************************

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
Dim rng As Range, rngCheck As Range, objShp As Shape

Set rngCheck = Intersect(Target, Range("I9:DX644"))

If Not rngCheck Is Nothing Then
  For Each rng In rngCheck
    With rng
      If Not .HasFormula Then
        Set objShp = Nothing
        On Error Resume Next
        Set objShp = Me.Shapes("shape_" & .Address(0, 0))
        Err.Clear
        On Error GoTo 0
        If IsNumeric(Application.Match(.Value, Array("a", "b", "c"), 0)) Then
          If objShp Is Nothing Then
            Set objShp = Me.Shapes.AddShape(msoShapeDiamond, .Left, .Top, .Width, .Height)
            objShp.Name = "shape_" & .Address(0, 0)
            objShp.Fill.Visible = False
          End If
        Else
          If Not objShp Is Nothing Then objShp.Delete
        End If
      End If
    End With
  Next
End If

Set rngCheck = Nothing
End Sub


Gruß Sepp


Bild

Betrifft: AW: Prüfen, ob Autoform bereits in Zelle vorhanden
von: Timo
Geschrieben am: 10.08.2015 17:37:04
Hallo Sepp,
Ich habe noch eine Anschlussfrage zu meiner Datei mit dem automatischen Einfügen einer Raute. Gerne, kann ich diese gegebenenfalls auch in einem neuen Forumsbeitrag stellen.
Ich denke, ich habe das mit dem Intersect-Befehl noch nicht so ganz verstanden. Ich habe ein Makro erstellt, das die Schriftgröße einzelner Werte vergrößert (diese werden auch aus dem Drop-Down-Menü ausgewählt). Das Makro funktioniert auch, aber ich würde das gerne wieder mit einem möglichst flüssigen Worksheet_Change-Ereignis lösen. Wäre super, wenn Du mir hierbei nochmals helfen könntest. Hier mein bisheriger Ansatz, bei dem ich versucht habe mein Makro und deine gestrige Lösung irgendwie zusammenzubringen:

Private Sub Worksheet_Change(ByVal Target As Range)
 
Dim rng As Range
If Intersect(Target, Range("I9:DX644")) Is Nothing Then
For Each rng In Intersect(Target, Range("I9:DX644"))
  
    If rng.Value = "a" Then
    
        With rng
     .Font.Size = .Height + 2
  
      End With
    End If
Next
End If
End Sub


 Bild

Beiträge aus den Excel-Beispielen zum Thema "Prüfen, ob Autoform bereits in Zelle vorhanden ist"