Sub Insert_Image() '変数の型を宣言 Dim base_path As String Dim file_name As String Dim file_path As String Dim i As Integer Dim pos_left As Single, pos_top As Single Dim Cell_Height As Double Dim Cell_Space As Double Dim shape As shape Dim Image_Height As Double Dim Image_scale As Double Dim Init_Row As Long Dim Init_Column As Long Dim selectedCell As Range Set selectedCell = Application.InputBox("画像を貼り付けを開始するセルを選択してください", "画像貼り付け開始セルの選択", Type:=8) '選択しているセルの位置を取得 Init_Row = selectedCell.row Init_Column = selectedCell.column '画像の拡大/縮小率を設定する Image_scale = InputBox("画像の拡大/縮小率(0.1～2.0)を入力してください", "拡大縮小率の入力") '画像フォルダ選択 Application.FileDialog(msoFileDialogFolderPicker).Title = "挿入する画像ファイルフォルダを選択してください" If Application.FileDialog(msoFileDialogFolderPicker).Show = True Then base_path = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1) & "\" '選択したフォルダのパスを格納 '選択したセルの左上の座標と高さを取得 With selectedCell pos_left = .Left pos_top = .Top Cell_Height = .Height End With 'With ActiveWindow.RangeSelection ' pos_left = .Left ' pos_top = .Top ' Cell_Height = .Height 'End With '画像ファイルパス取得 file_name = Dir(base_path, vbNormal) file_path = base_path & file_name i = 1 '画像貼り付けループ Do Until file_name = "" Set shape = ActiveSheet.Shapes.AddPicture(file_path, msoFalse, msoTrue, pos_left, pos_top, -1, -1) ' FileName:=file_path, _ ' LinkToFile:=msoFalse, _ ' SaveWithDocument:=msoTrue, _ ' Left:=pos_left, _ ' Top:=pos_top, _ ' Width:=300, _ ' Height:=200 Image_Height = shape.Height * Image_scale '画像の高さから、次の画像を挿入するセルまでの行数を計算する Cell_Space = Image_Height / Cell_Height Cell_Space = Application.RoundUp(Cell_Space, 0) + 3 With shape .LockAspectRatio = msoTrue '縦横比固定 .Height = Image_Height End With '次に画像を挿入するセルを選択 Cells(i * Cell_Space + Init_Row, Init_Column).Select With ActiveWindow.RangeSelection pos_left = .Left pos_top = .Top End With 'ファイルパスを更新 file_name = Dir() file_path = base_path & file_name i = i + 1 Loop End If End Sub