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
Hallöchen,
tja, wenn Du die 8 fix programmierst ... Nimm stattdessen die Schleifenvariable.
Danke schonmal für die Antwort,
Da ich keine weitere ERfahrung mit VBA's habe, benötige ich hier noch etwas mehr erklärung
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.
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
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.
Boah Danke!
Endlich funktionierts
Wie würde das ganze denn aussehen, wenn ich beim einfügen direkt zentriere?
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
. 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...
Danke!
Das werd ich direkt mal einbauen. Vielen Dank für die ausführliche Hilfe und die erklärenden Kommentare