VBA zentrieren der Bilder auf Bereich beschränken

[Capdo]

Guten Morgen allesamt,

Ich habe folgenden Code zum zentrieren meiner Bilder in einer Exceldatei. Momentan zentriert mir Excel damit sämtliche Bilder in dem Blatt. Nun will ich den code aber nur in einem bestimmten Bereich ausführen (G8:G27), damit die Bilder in einem anderen Blattbereich nicht mit zentriert werden.

Code:

For Each shp In ActiveSheet.Shapes
    With shp
        .Left = Cells(.BottomRightCell.Row, 7).Left + Cells(.BottomRightCell.Row, 7).Width / 2 - .Width / 2
        .Top = Cells(.BottomRightCell.Row, 7).Top + Cells(.BottomRightCell.Row, 7).Height / 2 - .Height / 2
    End With

Da ich mit VBA nicht viel Erfahrung habe, hoffe ich hier auf Hilfe!

Danke im Voraus!
Capdo

[Kuwer]

Hallo,

Code:

For Each shp In ActiveSheet.Shapes
    If Not Application.Intersect(Range("G8:G27"), shp.TopLeftCell) Is Nothing Then
        With shp
            .Left = Cells(.BottomRightCell.Row, 7).Left + Cells(.BottomRightCell.Row, 7).Width / 2 - .Width / 2
            .Top = Cells(.BottomRightCell.Row, 7).Top + Cells(.BottomRightCell.Row, 7).Height / 2 - .Height / 2
        End With
    End If

Gruß Uwe

[Capdo]

Danke für die schnelle und hilfreiche Lösung!

[Capdo]

Hallo nochmal,

ich bräuchte das ganze auch nochmal für diesen Code:

Code:

With ActiveSheet.Pictures
        .ShapeRange.LockAspectRatio = msoTrue
        .Height = Range("S3").Height
        .Placement = xlMoveAndSize

oder kann man beide Codes irgendwie zusammen zu führen?

Code:

Next
    With ActiveSheet.Pictures
        .ShapeRange.LockAspectRatio = msoTrue
        .Height = Range("S3").Height
        .Placement = xlMoveAndSize
       
'Bilder Zentrieren
       
For Each shp In ActiveSheet.Shapes
    If Not Application.Intersect(Range("p3:p3"), shp.TopLeftCell) Is Nothing Then
        With shp
            .Left = Cells(.BottomRightCell.Row, 16).Left + Cells(.BottomRightCell.Row, 16).Width / 2 - .Width / 2
            '.Top = Cells(.BottomRightCell.Row, 16).Top + Cells(.BottomRightCell.Row, 16).Height / 2 - .Height / 2
        End With
    End If
Next shp

Schöne Grüße,
Yann

[Capdo]

Ich habe es jetzt noch etwas probiert aber komme nicht weiter.
Meine Idee war es den Befehl 

Code:

If Not Application.Intersect(Range("F7:F16"), shp.TopLeftCell) Is Nothing Then

wiederum vor den Befehl den ich beschränken will zu setzen. Nun sieht der Code so aus:

Code:

If Not Application.Intersect(Range("F7:F16"), shp.TopLeftCell) Is Nothing Then
    With ActiveSheet.Pictures
        .ShapeRange.LockAspectRatio = msoTrue
        .Height = Range("S19").Height
        .Placement = xlMoveAndSize
    End With
End If

Ich bekomme aber nun die Fehlermeldung "Laufzeitfehler 91: Objektvariable oder With-Blockvariable nicht festgelegt"

Kann mir jemand sagen was ich falsch mache?

[Kuwer]

Hallo Yann,

vielleicht einfach mit With shp probieren?

Gruß Uwe

[Capdo]

Hey Uwe,

Danke kommt weiterhin die gleiche Fehlermeldung. Ich poste hier einmal meinen gesamten Code, vielleicht liegt der Fehler auch irgendwo anders? Ohne diese Beschränkung funktioniert der Code jedoch ohne Probleme nur dass halt alle Bilder in der Mappe der Größe angepasst werden, was ich aber nicht will.

Code:

Sub Bilder_einfügenTeamCars()

Dim wksA As Worksheet
Dim shpX As Shape
Dim rngTopLeftCell As Range
Dim rngZuLoeschenderBereich As Range
Set wksA = ActiveWorkbook.Worksheets("Championship Team")
Set rngZuLoeschenderBereich = wksA.Range("F7:F16")   
For Each shpX In wksA.Shapes
Set rngTopLeftCell = shpX.TopLeftCell
If Not Application.Intersect(rngZuLoeschenderBereich, rngTopLeftCell) Is Nothing Then
  shpX.Delete
End If
Next

Dim Pfad As String, Wiederholungen As Long
Dim shp As Shape
Dim x As Double
Dim y As Double

Pfad = "Speicherort"
For Wiederholungen = 7 To 16
Cells(Wiederholungen, 6).Activate
ActiveSheet.Pictures.Insert(Pfad & Cells(Wiederholungen, 6) & ".png").Select
Next
If Not Application.Intersect(Range("F7:F16"), shp.TopLeftCell) Is Nothing Then
    With shp
        .ShapeRange.LockAspectRatio = msoTrue
        .Height = Range("S19").Height
        .Placement = xlMoveAndSize
    End With
End If
       
For Each shp In ActiveSheet.Shapes
     If Not Application.Intersect(Range("F7:F16"), shp.TopLeftCell) Is Nothing Then
        With shp
            .Left = Cells(.BottomRightCell.Row, 6).Left + Cells(.BottomRightCell.Row, 6).Width / 2 - .Width / 2
            .Top = Cells(.BottomRightCell.Row, 6).Top + Cells(.BottomRightCell.Row, 6).Height / 2 - .Height / 2
        End With
    End If
Next shp

End Sub

Bitte entschuldigt falls der Code irgendwie Chaotisch wirkt, ich habe mir das meiste zusammen gegoogled bzw. erfragt 

[Kuwer]

Hallo,

ist auch irgendwie doof, wenn die betreffenden Shapes in der ersten Schleife des Makros gelöscht werden.

Gruß Uwe

[Capdo]

Das liegt daran, dass ich die shapes immer neu rein lade. Es geht darum, dass ich eine Tabelle für eine F1 Liga erstellen will und die Teamlables sich dem Fahrer anpassen. Daher lösch ich die Bilder zuerst bevor ich sie wieder neu an der richtigen Position wieder rein lade, was dann in der nächsten Schleife passiert bevor die Größe und Position dieser angepasst werden.

Gruß Yann

[Kuwer]

Alles klar. Dann mach ich jetzt mal den Hajo.