Soweit ich Ihre Frage verstehe, fehlt Ihnen ein Schlüsselelement: Bereiche haben Eigenschaften wie "Links", "Oben", "Rechts" und "Breite", genau wie Bilder. Hier ist eine Funktion, die ein Range
Objekt als Parameter übernimmt, den Benutzer zur Auswahl von Bildern auffordert und die Bilder dann in diesen Bereich einfügt. Schlüsselpunkt: Basierend auf Ihrer Anfrage wird es so geschrieben, dass das Seitenverhältnis nicht beibehalten wird, sodass Bilder gestaucht oder gestreckt wirken können.
Option Explicit Sub testImportPicturesToRange() ImportPicturesToRange Range("B3:H10") End Sub Function ImportPicturesToRange(rngTarget As Range) 'Declaration Dim picFormats As String, picPaths, picPath, pic Dim i As Long, numPics As Long, picWidth As Long 'Select the pictures to import picFormats = "*.gif; *.jpg; *.bmp; *.png; *.tif" picPaths = Application.GetOpenFilename("Pictures (" & picFormats & ")," & picFormats,, "Select Picture to Import",, True) 'Exit if user clicked Cancel If TypeName(picPaths) = "Boolean" Then Exit Function 'Initialize i = 0 numPics = 0 For Each picPath In picPaths If picPath <> False Then numPics = numPics + 1 Next picWidth = rngTarget.Width / numPics 'Import the pictures On Error Resume Next For Each picPath In picPaths If picPath <> False Then Set pic = ActiveSheet.Pictures.Insert(picPath) pic.ShapeRange.LockAspectRatio = msoFalse pic.Top = rngTarget.Top pic.Left = rngTarget.Left + (i * picWidth) pic.Height = rngTarget.Height pic.Width = picWidth i = i + 1 End If Next 'Cleanup Set pic = Nothing Set picPath = Nothing Set picPaths = Nothing End Function
UPDATE: Von dem, was ich in Ihrer Frage sehen kann, denke ich , dass Sie dies so implementieren möchten.
Private Sub Image1_Click() ImportPicturesToRange Range("C1") End Sub