(VBA実験)Excelに自動で複数画像貼り付け

Excelに画像貼り付け

ExcelのVBAで、複数の画像を一括で貼り付けます。VBAのコード好きではないですが、仕方ない。

Excelの別記事: セルをmmで指定し正方形にする

スポンサーリンク

動画で説明

コード

選択画面出てきたら、画像を複数選択してください。(CTRL+クリックで選択できます)

Sub img()
    Dim myFil As FileDialog
    Dim myPics As Variant
    Dim ct As Long
    
    ct = 1
    ' 貼り付ける画像の選択
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True  '//複数選択OK
        .Filters.Add "*.png;*.jpg", "*.png;*.jpg", 1
        .Show
        
        For Each myPics In .SelectedItems
            Call picInsert(myPics, ct)  '//関数
            ct = ct + 1
        Next
    End With
End Sub

Public Function picInsert(dt, ct)  'pic name data, number cnt
       'ActiveSheet.Pictures.Insert uPic
    With Sheets(1).Pictures.Insert(dt)   '// 画像を入れたいシート・ナンバー
        .Top = Cells(3 + (ct - 1) * 20, 2).Top
        .Left = Cells(3 + (ct - 1) * 20, 2).Left
        .Width = Range(Cells(3, 2), Cells(3, 7)).Width
    End With
End Function

With Application.FileDialog(msoFileDialogFilePicker)

msoFileDialogFilePickerユーザーがファイルを選択
msoFileDialogFolderPickerユーザーがフォルダーを選択できます。
msoFileDialogOpenユーザーがファイルを開くことができます。
msoFileDialogSaveAsユーザーがファイルを保存できます。

~.Show ダイアログ起動

Set uFil = Application.FileDialog(msoFileDialogFilePicker)
    uFil.Show
    MsgBox uFil.SelectedItems(1)
    

uFil.SelectedItems(1) …… 選択ファイルのパス取得

uFil.Filters.Add “説明” , “拡張子” , 1 フィルタ何番目に表示するか

 uFil.Filters.Add "*.png;*.jpg", "*.png;*.jpg", 1

画像ファイルのみ表示するようにする。

戻り値  開くボタン=-1 キャンセル=0

With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "*.png;*.jpg", "*.png;*.jpg", 1
        num = .Show
        If num = -1 Then
            uPic = .SelectedItems(1)
        End If
End With
MsgBox num

.AllowMultiSelect = True  画像複数選択

With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "*.png;*.jpg", "*.png;*.jpg", 1
        num = .Show
        If num = -1 Then
            uPic = .SelectedItems(1)
            uPic2 = .SelectedItems(2)
        End If
End With
MsgBox uPic
MsgBox uPic2
スポンサーリンク

画像を挿入する

アクティブシートのアクティブセル(左上)を起点に画像入れる。

ActiveSheet.Pictures.Insert ""

シートを指定する

Sheets(2).Pictures.Insert ""

sheet2に入れます。

シート指定+画像の大きさ指定

With Sheets(2).Pictures.Insert(uPic)
        .Top = Range("C3").Top
        .Left = Range("C3").Left
        .Width = Range("C3:G3").Width
End With

コメント

タイトルとURLをコピーしました