Excelマクロについて質問です。 画像のようにセル内に入力されたファイル名(セル結合済み)と フォルダ内の同じ名前の写真データを セルに合わせて自動で挿入されるようなマクロを探しています。

画像

Excel | Visual Basic264閲覧xmlns="http://www.w3.org/2000/svg">500

ベストアンサー

0

この返信は削除されました

その他の回答(3件)

0

これでどうでしょうか。 ※予め、画像があるフォルダを指定してから実行します。 ※セルに記入されたファイルが存在しない場合はメッセージ表示し、空白となります。 ※同じ名前(例えば[image1.jpeg][image1.png]の場合は画像フォルダを開きますので、そこから選択してください)。 ※拡張子は「jpg,jpeg,png,bmp」としています(以外は処理されません)。 ※今は質問の図にある4枠しか処理していません。 Sub sample() Dim i As Long, j As Long, x As Long, cnt As Long, flag As Integer Dim s As String, fname As String, fn As String Dim rX As Double, rY As Double Dim PicTop As Double, PicLeft As Double, PicWidth As Double, PicHeight As Double Dim PicFile As Variant Const fld As String = "C:\○○\" 'フォルダ指定 Application.ScreenUpdating = False fname = Dir(fld & "\*.*") Do While fname <> "" cnt = cnt + 1 fname = Dir() Loop For j = 1 To 10 Step 3 flag = 0 i = 0 x = 0 s = Cells(8, j).MergeArea(1, 1).Value fname = Dir(fld & "*.*") Do While fname <> "" If Split(fname, ".")(0) = s Then If Split(fname, ".")(1) = "jpg" _ Or Split(fname, ".")(1) = "jpeg" _ Or Split(fname, ".")(1) = "png" _ Or Split(fname, ".")(1) = "bmp" Then fn = fname i = i + 1 End If Else x = x + 1 End If fname = Dir() Loop If i = 1 Then ' ElseIf i > 1 And i < cnt Then MsgBox "[" & s & "]は同じ名前の画像が複数あります。" fn = Dir(CTCheck(fld)) ElseIf x = cnt Then MsgBox "[" & s & "]はこのフォルダには存在しません。" flag = 1 End If If flag = 0 Then PicFile = fld & fn PicTop = Cells(8, j).MergeArea.Top PicLeft = Cells(8, j).MergeArea.Left PicWidth = Cells(8, j).MergeArea.Width PicHeight = Cells(8, j).MergeArea.Height With ActiveSheet.Pictures.Insert(PicFile) rX = PicWidth / .Width rY = PicHeight / .Height If rX > rY Then .Height = .Height * rY Else .Width = .Width * rX End If .Left = PicLeft + (PicWidth - .Width) / 2 .Top = PicTop + (PicHeight - .Height) / 2 End With End If Next j Application.ScreenUpdating = True End Sub Function CTCheck(ByVal fld As String) Dim file_name As String ChDir fld file_name = Application.GetOpenFilename CTCheck = file_name End Function

この返信は削除されました

0

<前提> 画像はすべてマクロを実行するブックと同じフォルダ内にあります。 シートに入力されている画像名は、必ず jpg か png 形式で存在します。 <標準モジュール> Sub Test() Dim MyDir As String, rng As Range, Pic As String Dim WDT As Single, HGT As Single, CTP As Single, CLF As Single Dim PWD As Single, PHT As Single, FName As String MyDir = ActiveWorkbook.Path & "\" For Each rng In ActiveSheet.UsedRange If rng.MergeCells And rng.Address = rng.MergeArea(1, 1).Address Then rng.Select With Selection WDT = .Width HGT = .Height CTP = .Top CLF = .Left End With Pic = Dir$(MyDir & rng.Value & ".jpg") Select Case Pic Case Is <> "" ActiveSheet.Pictures.Insert(MyDir & rng.Value & ".jpg").Select Case Else ActiveSheet.Pictures.Insert(MyDir & rng.Value & ".png").Select End Select With Selection.ShapeRange .LockAspectRatio = msoTrue PWD = .Width PHT = .Height Select Case PHT / PWD Case Is >= HGT / WDT .Height = HGT .Left = CLF + (WDT - .Width) / 2 Case Else .Width = WDT .Top = CTP + (HGT - .Height) / 2 End Select End With End If Next End Sub

0

ちょっと長いですが、これでどうでしょうか? Sub 画像挿入() Const folPath As String = "C:\Users\User\Pictures" Dim trgRng As Range Dim trgShp As Shape Dim Kakucho As String, buf As String, trgKaku As String Dim kakuCnt As Long, picCnt As Long Dim trgWid As Single, trgHei As Single On Error GoTo Err_hdl For picCnt = 1 To 4 kakuCnt = 0 Set trgRng = Cells(8, picCnt * 3 - 2) buf = Dir(folPath & "\" & trgRng & ".*") Do If buf Like trgRng.Text & ".jpg" Or buf Like trgRng.Text & ".png" Then kakuCnt = kakuCnt + 1 trgKaku = buf End If buf = Dir() Loop Until buf = "" If kakuCnt = 1 Then If trgRng.Text = "" Then Exit Sub Application.ScreenUpdating = False trgWid = trgRng.MergeArea.Width trgHei = trgRng.MergeArea.Height Set trgShp = ActiveSheet.Shapes.AddPicture( _ Filename:=folPath & "\" & trgKaku, _ LinkToFile:=msoFalse, _ SaveWithDocument:=msoTrue, _ Left:=trgRng.Left, Top:=trgRng.Top, _ Width:=0, Height:=0) With trgShp .LockAspectRatio = msoTrue .ScaleWidth 1, msoTrue .ScaleHeight 1, msoTrue End With With trgShp If .Width < trgWid And .Height < trgHei Then If .Height < trgHei Then .Height = trgHei If .Width > trgWid Then .Width = trgWid End If .Left = .Left + (trgRng.MergeArea.Width - .Width) / 2 Else .Width = trgWid .Top = .Top + (trgRng.MergeArea.Height - .Height) / 2 End If Else If .Height > trgHei Then .Height = trgHei If .Width > trgWid Then .Width = trgWid End If .Left = .Left + (trgRng.MergeArea.Width - .Width) / 2 Else .Width = trgWid .Top = .Top + (trgRng.MergeArea.Height - .Height) / 2 End If End If End With Application.ScreenUpdating = False Else MsgBox "データが複数あります", vbExclamation End If Next picCnt Set trgRng = Nothing Set trgShp = Nothing Exit Sub Err_hdl: If Err.Number = 1004 Then MsgBox "ファイルが見つかりません", vbExclamation Else MsgBox "予期せぬエラーです", vbCritical End If End Sub