Mit VBA Bilder einfügen und zentrieren

[Capdo]

Hallo Leute,

Ich bin neu hier und hoffe das ihr mir weiter helfen könnt   Ich versuche nun seit einiger Zeit Bilder in meine Excel Tabelle einzufügen und zu zentrieren. Das ganze soll automatisch mit VBA laufen. Da ich aber nicht viel Ahnung von VBA's habe, habe ich mir von unterschiedlichen Seiten einen Code zusammengebastelt. Vorab, in den Zellen S8-S27 stehen die Namen der Formel1 Teams. VBA's soll nun die Teamlabels in einem Ordner suchen und einfügen. Das klappt auch soweit ohne Probleme. Nun will ich jedoch die Labels in der spezifischen Zelle zentrieren. Von links oben in die Mitte zu zentrieren klappt auch, aber sobald ich die Bilder auch in der Höhe zentrieren will, legt mir das VBA alle Fotos in eine Zelle (S8). Sie sind zwar dann darin sowohl in der Höhe als auch in der Breite zentriert, aber hallt nicht mehr auf die Zellen S8-S27 verteilt. Vielleicht kann mir ja hier irgendwer helfen 

Danke schonmal im Voraus,
Capdo

P.S. Die "..." beim Pfad sind in meinem Code nicht, dort steht der komplette Pfad.

Code:

Sub Bilder_einfŸgen()

Dim Pfad As String, Wiederholungen As Long
'On Error Resume Next
Pfad = "...\F1\LFR\Teamlabels\Fahrer\"
For Wiederholungen = 8 To 27
Cells(Wiederholungen, 19).Activate
ActiveSheet.Pictures.Insert(Pfad & Cells(Wiederholungen, 19) & ".png").Select
Next
    With ActiveSheet.Pictures
        .ShapeRange.LockAspectRatio = msoTrue
        .Height = Range("S32").Height
        .Placement = xlMoveAndSize
        Dim shp As Shape
        Dim x As Double
        Dim y As Double
        x = Cells(1, 19).Left + Cells(1, 19).Width / 2
        y = Cells(8, 19).Top + Cells(8, 19).Height / 2
        For Each shp In ActiveSheet.Shapes
        shp.Left = x - shp.Width / 2
        shp.Top = y - shp.Height / 2
    End With
End Sub

[schauan]

Hallöchen,

tja, wenn Du die 8 fix programmierst ... Nimm stattdessen die Schleifenvariable.

[Capdo]

Danke schonmal für die Antwort,

Da ich keine weitere ERfahrung mit VBA's habe, benötige ich hier noch etwas mehr erklärung 

[schauan]

Hallöchen,

wer hat Dir denn die Schleife programmiert?

...
For Wiederholungen = 8 To 27
Cells(Wiederholungen, 19).Activate 'hier ist die Zelladressierung ok
...
y = Cells(8, 19).Top + Cells(8, 19).Height / 2
For Each shp In ActiveSheet.Shapes
shp.Left = x - shp.Width / 2
shp.Top = y - shp.Height / 2

---

ansonsten erst mal nur noch ein Hinweis - Dimensionieren von Variablen macht man in der Regel nicht in einer Schleife.

[Capdo]

Hab mir mit etwas Copy Paste das ganze zusammengebaut, muss aber gestehen, dass ich das ganze nicht zu 100% verstehe

---

Wenn ich das jetzt richtig verstehe, meinst du statt Cells(8, 19), dass Cells(Wiederholungen, 19) angegeben werden muss?
Jedoch behebt das bei mir das Problem nicht, mir werden sämtliche Bilder jetzt noch immer in einer Zelle zentriert, statt über die verschiedenen zellen verteilt.

Code:

Dim Pfad As String, Wiederholungen As Long
'On Error Resume Next
Pfad = "...\F1\LFR\Teamlabels\Fahrer\"
For Wiederholungen = 8 To 27
Cells(Wiederholungen, 19).Activate
ActiveSheet.Pictures.Insert(Pfad & Cells(Wiederholungen, 19) & ".png").Select
Next
    With ActiveSheet.Pictures
        .ShapeRange.LockAspectRatio = msoTrue
        .Height = Range("S32").Height
        .Placement = xlMoveAndSize
       
'Bilder Zentrieren
       
        Dim shp As Shape
        Dim x As Double
        Dim y As Double
        x = Cells(Wiederholungen, 19).Left + Cells(Wiederholungen, 19).Width / 2
        y = Cells(Wiederholungen, 19).Top + Cells(Wiederholungen, 19).Height / 2
        For Each shp In ActiveSheet.Shapes
        shp.Left = x - shp.Width / 2
        shp.Top = y - shp.Height / 2
    Next
    End With
End Sub

[00202]

Hallo,  

schreibe es so:  

Code:

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

Die vier Zeilen über "For..." mit x und y kannst du löschen. Man könnte die Bilder auch gleich beim einfügen zentrieren.

[Capdo]

Boah Danke!

Endlich funktionierts 

Wie würde das ganze denn aussehen, wenn ich beim einfügen direkt zentriere?

[00202]

Hallo,  

das würde so gehen (im Code sind Kommentare - bitte beachten!):

Code:

Option Explicit
Public Sub Main()
    Dim strPath As String
    Dim objShape As Shape
    Dim lngCount As Long
    On Error GoTo Fin
    ' Pfad anpassen - abschliessenden Backslash nicht vergessen!!!
    strPath = "C:\TMP\"
    ' Bildschirmaktualisierung ausschalten
    Application.ScreenUpdating = False
    ' Die folgende Codezeile ist auskommentiert, denn die löscht ALLE BIlder.
    ' Wenn du noch ander Bilder im Tabellenblatt hast, muss angepasst werden.
    ' VORSICHT! Bilder löschen, damit bei mehrfach ausführen nicht mehrere Bilder in einer Zelle sind.
    Tabelle1.Pictures.Delete
    ' Schleife anpassen. Habe hier nur mit 4 Bilder getestet.
    For lngCount = 8 To 11
        ' Tabelle1 ist der Codename des Tabellenblattes
        ' Zu CodeName siehe https://docs.microsoft.com/de-de/office/vba/api/excel.worksheet.codename
        ' Also EVENTUELL anpassen! in einem englischen Excel wäre Tabelle1 Sheet1
        With Tabelle1.Cells(lngCount, 19)
            Set objShape = .Parent.Shapes.AddPicture(strPath & .Value & ".png", msoFalse, msoTrue, .Left, .Top, -1, -1)
            With objShape
                .LockAspectRatio = msoTrue
                .Height = .Parent.Range("S32").Height
                .Placement = xlMoveAndSize
                .Left = .Parent.Cells(.BottomRightCell.Row, 19).Left + .Parent.Cells(.BottomRightCell.Row, 19).Width / 2 - .Width / 2
                .Top = .Parent.Cells(.BottomRightCell.Row, 19).Top + .Parent.Cells(.BottomRightCell.Row, 19).Height / 2 - .Height / 2
            End With
        End With
        Set objShape = Nothing
    Next lngCount
Fin:
    Set objShape = Nothing
    Application.ScreenUpdating = True
    If Err.Number <> 0 Then MsgBox "Error: " & Err.Number & " " & Err.Description
End Sub

Pfad anpassen. Habe es auch nur mit 4 Bilder getestet, also Schleifenanzahl anpassen.

Mit "Pictures.Insert" kannst du hantieren, wenn nur du mit der Datei arbeitest. Schickst du die per Mail weiter, sieht dein Gegenüber keine Bilder.

Nimm lieber "Shapes.AddPicture". Siehe Shapes.AddPicture-Methode...

[Capdo]

Danke! 

Das werd ich direkt mal einbauen. Vielen Dank für die ausführliche Hilfe und die erklärenden Kommentare