Het lukt niet om positie van Shape aan te passen door invoeren waarde coördinaten

Status
Niet open voor verdere reacties.
S

SdeKoning

Gebruiker
Lid geworden
30 jan 2018
Berichten
5
Beste VBA'ers,

momenteel ben ik bezig met afstuderen. Hiervoor probeer ik een stukje procesverbetering door te voeren van het maken van werkinstructies. Door middel van invoeren van lengte, breedte en positie van meerdere shapes probeer ik sjablonen te creëren om tekeningen standaard te kunnen maken. (zodat alleen een tabel met maatvoeringen aangepast hoeft te worden en een tekening automatisch wordt gecreëerd)
In 1 worksheet moet ik bijvoorbeeld 4 rechthoeken plaatsen en deze op een bepaalde positie neerzetten. Het positioneren van de Shapes lukt momenteel niet, ik probeer iets zoals:.

Code: 
Sub ShapesPosition()
Dim sShape As Shape

Set sShape = ActiveSheet.Shapes("Rectangle 1")

    With sShape
        .Top = ("C2")
        .Left = ("C3")
    End With
    
End Sub
dan gebeurt er niks

De grootte van de shapes lukt wel door middel van code:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

    If Not Intersect(Target, Target.Worksheet.Range("B2")) Is Nothing Then
        ActiveSheet.Shapes("Rectangle 1").Height = Target.Value
    ElseIf Not Intersect(Target, Target.Worksheet.Range("B3")) Is Nothing Then
        ActiveSheet.Shapes("Rectangle 1").Width = Target.Value
    End If
    
    If Not Intersect(Target, Target.Worksheet.Range("B4")) Is Nothing Then
        ActiveSheet.Shapes("Rectangle 2").Height = Target.Value
    ElseIf Not Intersect(Target, Target.Worksheet.Range("B5")) Is Nothing Then
        ActiveSheet.Shapes("Rectangle 2").Width = Target.Value
    End If
    
    If Not Intersect(Target, Target.Worksheet.Range("B6")) Is Nothing Then
        ActiveSheet.Shapes("Rectangle 3").Height = Target.Value
    ElseIf Not Intersect(Target, Target.Worksheet.Range("B7")) Is Nothing Then
        ActiveSheet.Shapes("Rectangle 3").Width = Target.Value
    End If
    
    If Not Intersect(Target, Target.Worksheet.Range("B8")) Is Nothing Then
        ActiveSheet.Shapes("Rectangle 4").Height = Target.Value
    ElseIf Not Intersect(Target, Target.Worksheet.Range("B9")) Is Nothing Then
        ActiveSheet.Shapes("Rectangle 4").Width = Target.Value
    End If



End Sub

Kan iemand mij vertellen hoe ik deze shapes kan positioneren? Alvast bedankt!
 
zoiets?
Code: 
Sub dotch()
With ActiveSheet
.Shapes("Rectangle 1").Left = .Cells(2, 3).Left
.Shapes("Rectangle 1").Top = .Cells(2, 3).Top
End With
End Sub
 
Met die code verplaatsen de shapes zich niet. er komt ook geen foutmelding
 
Dan doe jij iets niet goed.
Werkend vbtje in bijlage.
 

Bijlagen

  • verplaats.xlsb
    18 KB · Weergaven: 31
Oh ja maar wat ik nog eigelijk graag wil is dat de informatie van de positie uit de worksheet word gehaald. en niet ingevoerd in de vba code. kan dat?
 
Zo dan ?
De eerste keer na het downloaden krijg je een foutmelding, gewoon beëindigen drukken.
 

Bijlagen

  • verplaats.xlsb
    16,8 KB · Weergaven: 29
Ja dit is hem! ik moet alleen i.p.v. een cel als positie een aantal punten van Left en Top af zitten (soort coordinaten). moet ik dan (ByVal Target As Range) aanpassen?
 
Versie 3
 

Bijlagen

  • verplaats.xlsb
    15,4 KB · Weergaven: 37
Of bedoel je dit ?

Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    With Shapes("Rechthoek 1")
       .Top = Target.Top + [C2].Value
       .Left = Target.Left + [C3].Value
    end with
End Sub


@Dotch

Activesheet is overbodig in een gebeurteniscode van de activesheet zelf.
 
Laatst bewerkt:
Het heeft geen zin de gebeurtenis Selection_change te gebruiken als de rechthoeken maar 1 keer gepositioneerd moeten worden.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan