Registriert seit: 10.06.2022
Version(en): 365
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
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
13.10.2022, 15:27
(Dieser Beitrag wurde zuletzt bearbeitet: 13.10.2022, 16:45 von Kuwer.
Bearbeitungsgrund: End With durch End If ersetzt
)
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
Registriert seit: 10.06.2022
Version(en): 365
Danke für die schnelle und hilfreiche Lösung!
Registriert seit: 10.06.2022
Version(en): 365
14.10.2022, 17:09
(Dieser Beitrag wurde zuletzt bearbeitet: 14.10.2022, 17:12 von 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
Registriert seit: 10.06.2022
Version(en): 365
14.10.2022, 20:20
(Dieser Beitrag wurde zuletzt bearbeitet: 14.10.2022, 20:21 von 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?
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
Hallo Yann,
vielleicht einfach mit With shp probieren?
Gruß Uwe
Registriert seit: 10.06.2022
Version(en): 365
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
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
Hallo,
ist auch irgendwie doof, wenn die betreffenden Shapes in der ersten Schleife des Makros gelöscht werden.
Gruß Uwe
Registriert seit: 10.06.2022
Version(en): 365
14.10.2022, 21:53
(Dieser Beitrag wurde zuletzt bearbeitet: 14.10.2022, 21:54 von 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
Registriert seit: 17.04.2014
Version(en): MS Office 365(32)
Alles klar. Dann mach ich jetzt mal den Hajo.
Folgende(r) 1 Nutzer sagt Danke an Kuwer für diesen Beitrag:1 Nutzer sagt Danke an Kuwer für diesen Beitrag 28
• Capdo
|