Prüfen, ob Autoform bereits in Zelle vorhanden ist

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

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

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

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

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

' ********************************************************************** ' 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

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

Beliebteste Forumthreads (12 Monate)

Prüfen, ob Autoform bereits in Zelle vorhanden ist

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

345 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Prüfen, ob Autoform bereits in Zelle vorhanden ist

12 Beiträge zum Forumthread Beiträge zu diesem Forumthread

345 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

12
Beiträge zum Forumthread

Beiträge zu diesem Forumthread