Opgelost Macro wist bestaande shape niet

  • Onderwerp starter Onderwerp starter KeBr
  • Startdatum Startdatum
Dit topic is als opgelost gemarkeerd
Status
Niet open voor verdere reacties.
K

KeBr

Gebruiker
Lid geworden
25 apr 2016
Berichten
180
Beste Formleden,

Ik heb een macro waarbij bestaande shapes in een regel verwijderd moeten worden voordat er een nieuwe wordt geplaatst.
Als er een wijziging plaats vind in kolommen "C, E, G" De nieuwe shape wordt wel geplaatst, maar de oude blijven ook staan.

Verder zit in de macro een vertikaal zoek argument, alleen pakt die maar één kleur.

onderstaande macro: zie ook de bijlage.
Alvast bedankt voor jullie reacties

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim ShpNum As String

'Check if E or F date columns and ignore if not
If Intersect(Target, Range("C12:E50", "G12:G50")) Is Nothing Then Exit Sub 'Edit 12 & or 50 if inappropriate
'Check if more than one cell and ignore if yes
If Target.Count > 1 Then Exit Sub

'Otherwise...
r = Target.Row
' ignore if an empty Column C in row
If Cells(r, 7) = "" Then Exit Sub

'otherwise a date has been changed

ShpName = "SHP_" & Cells(r, 7) 'Shape Name
'Delete current shape of that name if it exists
On Error Resume Next
    For Each xshape In TagetRow.ShapesRange(Array(ShpName)).Delete
    If xshape.TopLeftCell.Row = myRow Then xshape.Delete
Next
    'get equal date  cells
    LftCell = Cells(r, 5) - Cells(10, 5) + 8
    RtCell = Cells(r, 6) - Cells(10, 5) + 8
   On Error GoTo 0
 
Select Case Cells(r, 7) = Value

Case Is <> 0
    'diamond for Milestone date
    Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeDiamond, Cells(r, LftCell).Left, Cells(r, LftCell).Top + 2, Cells(r, LftCell).Width, Cells(r, LftCell).Height - 4)
      NewShp.Fill.ForeColor.RGB = FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
        NewShp.Line.ForeColor.RGB = FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
          
Case Else
    On Error GoTo OnlyONEDate:
    'Get date ranges
    Set DtRng = Range(Cells(r, LftCell), Cells(r, RtCell))
        LftCell = Cells(r, 5) - Cells(10, 5) + 8
        RtCell = Cells(r, 6) - Cells(r, 5) + 12
    'if number in G then add a rectangle
    If Cells(r, 3) = "fase" Then
    Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, DtRng.Left, DtRng.Top + 5, DtRng.Width, DtRng.Height - 10)
          NewShp.Fill.ForeColor.RGB = FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
          NewShp.Line.ForeColor.RGB = FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
       Else
    
      'Otherwise if text in C add arrow  bar
    Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeLeftRightArrow, DtRng.Left, DtRng.Top + 3, DtRng.Width, DtRng.Height - 6)
          NewShp.Fill.ForeColor.RGB = FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
          NewShp.Line.ForeColor.RGB = FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
    End If
End Select
'Name shape as per value
   NewShp.Name = ShpName

OnlyONEDate:
On Error GoTo 0

End Sub
 

Bijlagen

Laatst bewerkt door een moderator:
Haal die 'On Error Resume Next' weg en verander eens naar:
Code: 
'On Error Resume Next
    For Each xshape In Shapes
    If xshape.TopLeftCell.Row = Target.Row Then xshape.Delete
Next
 
In kolom F

PHP: 
=E12+G12-(G12<>0)(/php]
 
Option Explicit had hier een paar fouten kunnen voorkomen.
ShpNum gedeclareerd, ShpName gebruikt.
myRow niet gedeclareerd en krijgt ook geen waarde
TagetRow en ShapesRange wordt verbloemd door On Error Resume Next.
 
ach, vroeger was ik ook een "option explicit"-fan, nu ben ik explicit geen fan.
 
Bedankt voor jullie reacties, De oude shapes worden nu netjes verwijderd.

Ik had ook nog een vraag gesteld met betrekking tot kleuren van de Shapes. Dit staat in de macro zoals hieronder. echter krijg ik alleen maar zwarte shapes.
Ik heb het met "Vert.zoeken" en "Index Match"geprobeerd, beide hetzelfde resultaat.
De RGB codes staan op Blad3
Case Is <> 0
'diamond for Milestone date
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeDiamond, Cells(r, LftCell).Left, Cells(r, LftCell).Top + 2, Cells(r, LftCell).Width, Cells(r, LftCell).Height - 4)
NewShp.Fill.ForeColor.RGB = FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
NewShp.Line.ForeColor.RGB = FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"

Case Else
On Error GoTo OnlyONEDate:
'Get date ranges
Set DtRng = Range(Cells(r, LftCell), Cells(r, RtCell))
LftCell = Cells(r, 5) - Cells(10, 5) + 8
RtCell = Cells(r, 6) - Cells(r, 5) + 12
'if number in G then add a rectangle
If Cells(r, 3) = "fase" Then
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeRectangle, DtRng.Left, DtRng.Top + 5, DtRng.Width, DtRng.Height - 10)
NewShp.Fill.ForeColor.RGB = FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
NewShp.Line.ForeColor.RGB = FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
Else

'Otherwise if text in C add arrow bar
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeLeftRightArrow, DtRng.Left, DtRng.Top + 3, DtRng.Width, DtRng.Height - 6)
NewShp.Fill.ForeColor.RGB = FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
NewShp.Line.ForeColor.RGB = FormulaLocal = "VERT.ZOEKEN(range(C12:C50);Blad3!E3:I28;5;onwaar)"
End If
 
Geen idee wat het allemaal moet worden, maar hier een voorbeeld.
Deze bovenste twee regels boven de Select Case plaatsen zoals hier:
Code: 
x = Application.Match(Cells(r, 3), Blad3.Columns(5), 0)
  If IsNumeric(x) Then fc = Blad3.Cells(x, 5).Interior.ColorIndex
Select Case Cells(r, 7) = Value
Daarna kun je de kleur ophalen met:
Code: 
NewShp.Fill.ForeColor.SchemeColor = fc
NewShp.Line.ForeColor.SchemeColor = fc
 
Laatst bewerkt:
Heb je mijn bijlage überhaupt bekeken ?
 
De Help in Office 365 is bij lange na niet wat Excel 2007 was; alles is online en waardeloos.
Kan mijn vorig schrijven niet meer wijzigen.

Code: 
fc = RGB(Blad3.Cells(x, 6), Blad3.Cells(x, 7), Blad3.Cells(x, 8))
en verder:
Code: 
NewShp.Fill.ForeColor.RGB = fc
 NewShp.Line.ForeColor.RGB = fc
 
Beste HSV,

Ik kan nu wel de kleuren laten wijzigen. Echter met de verwijzing wordt een andere kleur opgehaald dan welke correspondeert. Het is wel zo dat vermelde naam altijd dezelfde kleur ophaalt.
Ik heb het aangepast bestand hierbij gevoegd
 

Bijlagen

Zie mijn laatste aangepaste schrijven van 17:36 uur.
 
Beste snb, Sorry ik had jou reactie niet gezien. deze werkt overigens perfect. De Macro is ook gelijk een stuk korter.
Bedankt
 
Beste HSV,
Ik heb jou laatste aanpassing van 17.36 in mijn macro gezet. Hiermee krijgen echter alle shapes dezelfde kleur.

In elk geval bedankt voor het meedenken.
 
Dan zal je iets verkeerds hebben overgenomen.
Zie bestand.
 

Bijlagen

Beste HSV, ik heb jou bestand gedownload en geopend. daar krijg ik dezelfde fout als wat ik al gemaakt had. Ik weet niet waarom het bij jou wel werkt.
Mogelijk ligt het aan Office 365 dat ik gebruik.
 
Nog een vraagje, hoe kan ik een vraag als opgelost zetten.
 
Maakt niet uit, ik gebruik ook Office 365 en hier wijzigen de kleuren bij de naam in kolom C van Blad2 in die van de overeenkomstige kleuren van Blad3.

Je vraag op opgelost zetten kon je eerder doen in je openingspost, maar ik weet niet of dit al geïntegreerd is in de nieuwe vormgeving van Helpmij.nl
 
Heb hem nog een keer geopend, Nu veranderen de kleuren inderdaad. Echter klopt de uitvoer niet meer. bij de eerst actie, als er een 0 staat in kolom 7 moet er een Diamond komen. Dat is nu net andersom.

Ook loopt de macro vast als ik in kolom 7 het nummer op 0 zet. Dit op de op een na laatste regel (vet gedrukt)
'Otherwise if text in C add arrow bar
Set NewShp = ActiveSheet.Shapes.AddShape(msoShapeLeftRightArrow, DtRng.Left, DtRng.Top + 3, DtRng.Width, DtRng.Height - 6)
NewShp.Fill.ForeColor = fc
NewShp.Line.ForeColor = fc 'FormulaLocal
 
Zou kunnen kloppen, daar heb ik ook niets mee gedaan
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan