選択した写真を自動で貼り付けるエクセルファイルを
作成しました。VBAを使用しています。
独学で作成しているもので、効率的と
は言えないとは思いますが、皆さんの参考になれば
幸いです。
下記に3パターン記載しましたのでコピペして
使用してください。
'------------------------------------------------
Sub 写真貼付1name() 'ファイル名付き
'ファイル読み出し用変数
Dim filename As Variant
'写真読み込み用変数
Dim pic As Shape
'ファイルを纏めて読み込む
filename = Application.GetOpenFilename("JPG,*.jpg", MultiSelect:=True)
'filenameの配列か確認
If IsArray(filename) Then
'ファイル選択数分繰り返す
For i = 1 To UBound(filename)
'ファイル名表示
ActiveCell.Offset = filename(i)
'オブシェクト名を省略
With ActiveCell
'写真のサイズをセルの大きさに合わせて貼付け
Set pic = ActiveSheet.Shapes.AddPicture(filename:=filename(i), linktofile:=False, savewithdocument:=True, _
Left:=.Left + 2, Top:=.Top + 2, Width:=.MergeArea.Width - 4, Height:=.MergeArea.Height - 4)
End With
'セルの貼り付け位置を設定
ActiveCell.Offset(1, 0).Activate
Next i
End If
End Sub
'-----------------------------------------------------
Sub 写真貼付22()　’2列表示
'ファイル読み出し用変数
Dim filename As Variant
Dim t As Long
'写真読み込み用変数
Dim pic As Shape
'ファイル読み込み
filename = Application.GetOpenFilename("JPG,*.jpg", MultiSelect:=True)
'filenameの配列か確認
If IsArray(filename) Then
'ファイル選択数分繰り返す
For i = 1 To UBound(filename) Step 2 '2枚=2、3枚=3
For ii = 1 To 2 '行方向枚数分繰り返し
'オブシェクト名を省略
With ActiveCell
t = t + 1 'henkou
'写真のサイズをセルの大きさに合わせて貼付け
Set pic = ActiveSheet.Shapes.AddPicture(filename:=filename(t), linktofile:=False, savewithdocument:=True, _
Left:=.Left + 2, Top:=.Top + 2, Width:=.MergeArea.Width - 4, Height:=.MergeArea.Height - 4)
End With
'貼付けセル位置を設定
ActiveCell.Offset(0, 1).Activate '列方向にアクティブセルを移動(行方向,列方向)
If t = UBound(filename) Then GoTo sub2 '写真が最終の時終了させる
Next ii
ActiveCell.Offset(1, -2).Activate '行方向にアクティブセルを移動(行方向,列方向)

Next i
sub2:
End If
End Sub
'-----------------------------------------------------------
Sub 写真貼付33()　’3列表示
'ファイル読み出し用変数
Dim filename As Variant
Dim t As Long
'写真読み込み用変数
Dim pic As Shape
'ファイルを纏めて読み込む
filename = Application.GetOpenFilename("JPG,*.jpg", MultiSelect:=True)
'filenameの配列か確認
If IsArray(filename) Then
'ファイル選択数分繰り返す
For i = 1 To UBound(filename) Step 3 'step　2枚=2、3枚=3
For ii = 1 To 3 '行方向枚数分繰り返し　2枚=2、3枚=3
'オブシェクト名を省略
With ActiveCell
t = t + 1 'henkou
'写真のサイズをセルの大きさに合わせて貼付け
Set pic = ActiveSheet.Shapes.AddPicture(filename:=filename(t), linktofile:=False, savewithdocument:=True, _
Left:=.Left + 2, Top:=.Top + 2, Width:=.MergeArea.Width - 4, Height:=.MergeArea.Height - 4)
End With
'貼付けセル位置を設定
ActiveCell.Offset(0, 1).Activate '列方向にアクティブセルを移動(行方向,列方向)
If t = UBound(filename) Then GoTo sub2 '写真が最終の時終了させる
Next ii
ActiveCell.Offset(1, -3).Activate '行方向にアクティブセルを移動(行方向,列方向)

Next i
sub2:
End If
End Sub
'----------------------------------------------------------