VBA zentrieren der Bilder auf Bereich beschränken

[schauan]

Hallöchen,

bei den Schleifen hast Du
For Each shpX In ActiveSheet.Shapes
bzw
For Each shp In ActiveSheet.Shapes

Dadurch erfolgt eine Zuweisung der Bilder zur Objetvariable.

Im mittleren Teil hast Du nach dem Einfügen Deine Prüfung ohne eine Zuweisung. shp steht also für nix
Bau einfach wieder eine Schleife drum herum.

[Capdo]

Boah vielen Dank! Funktioniert jetzt einwandfrei! Danke euch für eure Hilfe 

Gruß Yann

---

Hey, ich schon wieder
Leider wird die Veränderung der Größe nicht in dem Bereich beschränkt.. Es wird weiterhin jedes Bild im Blatt verändert   Hab meinen jetztigen Code nochmal unten angefügt

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
For Each shp In ActiveSheet.Shapes
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
Next shp
       
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

[Kuwer]

Hallo,

Code:

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

  Pfad = "Speicherort"
  For Wiederholungen = 7 To 16
    With wksA.Cells(Wiederholungen, 6)
      With wksA.Shapes.AddPicture(Filename:=Pfad & wksA.Cells(Wiederholungen, 6).Value & ".png", _
                                  LinkToFile:=msoFalse, _
                                  SaveWithDocument:=msoTrue, _
                                  Left:=.Left, Top:=.Top, Width:=-1, Height:=wksA.Range("S19").Height)
        .LockAspectRatio = msoTrue
        .Placement = xlMoveAndSize
        .Left = wksA.Cells(.BottomRightCell.Row, 6).Left + wksA.Cells(.BottomRightCell.Row, 6).Width / 2 - .Width / 2
        .Top = wksA.Cells(.BottomRightCell.Row, 6).Top + wksA.Cells(.BottomRightCell.Row, 6).Height / 2 - .Height / 2
      End With
    End With
  Next Wiederholungen
End Sub

Gruß Uwe

[Capdo]

Hallo Uwe!

Danke für den Umbau des Codes, der läuft auch jetzt perfekt!

Nun wollte ich den Code zudem in einem anderen Bereich G7:G16 durchlaufen lassen.
Nach meinem Verständnis müsste ich dafür ja dann die Befehle 

Code:

wksA.Cells(Wiederholungen, 6) und wksA.Cells(.BottomRightCell.Row, 6)

in

Code:

wksA.Cells(Wiederholungen, 7)  und wksA.Cells(.BottomRightCell.Row, 7)

umöndern und zusätzlich bei zuLoeschenderBereich die Range zu "G7:G16" anpassen. Der Code fragt dann auch folglich die richtigen Zellen ab, allerdings verziehen sich die Bilder dann komplett in der Breite. Was habe ich übersehen?

Gruß und danke nochmal für die Mühe!
Yann

---

Okay habe es jetzt gelöst in dem ich die Width wie die Height aufgebaut habe, damit kriege ich es hin!

Danke für die tolle Hilfe!
Gruß,
Yann