仕事で写真報告書を作っています。 3枚毎に貼りたいのですがどのようにすればよろしいでしょうか。

画像
補足

B3からスタートして、下に3枚貼り そのあとK3へ移り下に3枚貼る作業を行いたいです。 現状B3(セル結合されている部分)のところで ダブルクリックすると写真選択できて サイズまで統一されるようになっております。 会社支給の報告書なので極力このフォーマットは使用したいです。 よろしくお願いいたします。

Visual Basic | Excel64閲覧

ベストアンサー

1

1人がナイス!しています

ThanksImg質問者からのお礼コメント

ありがとうございました。 ほんとに助かりました。、

お礼日時:2020/11/25 7:52

その他の回答(1件)

0

難しい事しないで出来ると思います。 Sub test() Dim strFilter As String Dim Filenames As Variant Dim objShape As Shape Dim i As Integer, j As Integer Dim r As Long, c As Long Dim shp As Shape strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png" Filenames = Application.GetOpenFilename( _ FileFilter:=strFilter, Title:="図の挿入(複数選択可)", MultiSelect:=True) If Not IsArray(Filenames) Then Exit Sub Application.ScreenUpdating = False Call BubbleSort_Str(Filenames, True, vbTextCompare) For i = LBound(Filenames) To UBound(Filenames) j = j + 1 '添付セル行 If j Mod 3 = 0 Then r = 41 Else r = (j Mod 3) * 19 - 16 End If '添付セル列 c = Int((j - 1) / 3) * 9 + 2 With Cells(r, c).MergeArea Set shp = ActiveSheet.Shapes.AddPicture(Filenames(i), LinkToFile:=False, SaveWithDocument:=True, Left:=.Left, Top:=.Top, Width:=0, Height:=0) shp.ScaleHeight 1, True shp.ScaleWidth 1, True shp.LockAspectRatio = True shp.Width = .Width If shp.Height <= .Height Then shp.Top = .Top + (.Height - shp.Height) / 2 Else shp.Height = .Height shp.Left = .Left + (.Width - shp.Width) / 2 End If End With Next i Application.ScreenUpdating = True MsgBox UBound(Filenames) & "枚の画像を挿入しました", vbInformation End Sub