ローカルフォルダから特定の画像をExcelにインポートする

Question

私はVBAを初めてお使いになりました。私は職場での挑戦を通して自分のやり方を混乱させています。

私は、フォルダ内の特定の画像をワークシートに取り込むための簡単なコードを探しています。私はコーディング言語に本当に苦労しており、多くは頭を悩ませています。

私は基本的に、マクロが列Aのすべての参照を見て、関連するピクチャをドライブ上のフォルダから隣接する列に戻すようにします。列Aの参照は、拡張子のないファイル名になります。私がいる

Option Explicit 

Sub AddOlEObject() 

    Dim mainWorkBook As Workbook 
    Dim Folderpath As String 
    Dim fso, NoOfFiles, listfiles, fls, strCompFilePath 
    Dim counter 


    Dim shp As Shape 
    For Each shp In ActiveSheet.Shapes 
    If shp.Type = msoPicture Then shp.Delete 
    Next shp 

    Set mainWorkBook = ActiveWorkbook 
    Sheets("Sheet1").Activate 
    Folderpath = "C:\Users\grahamb\Desktop\TEST" 
    Set fso = CreateObject("Scripting.FileSystemObject") 
    NoOfFiles = fso.GetFolder(Folderpath).Files.Count 
    Set listfiles = fso.GetFolder(Folderpath).Files 
    For Each fls In listfiles 
     strCompFilePath = Folderpath & "\" & Trim(fls.Name) 
     If strCompFilePath <> "" Then 


      If (InStr(1, strCompFilePath, "jpg", vbTextCompare) > 1 _ 
      Or InStr(1, strCompFilePath, "jpeg", vbTextCompare) > 1 _ 
      Or InStr(1, strCompFilePath, "png", vbTextCompare) > 1) Then 
       counter = counter + 1 
        Sheets("Sheet1").Range("A" & counter).Value = fls.Name 
        Sheets("Sheet1").Range("B" & counter).ColumnWidth = 25 
       Sheets("Sheet1").Range("B" & counter).RowHeight = 100 
       Sheets("Sheet1").Range("B" & counter).Activate 
       Call insert(strCompFilePath, counter) 
       Sheets("Sheet1").Activate 
      End If 
     End If 
    Next 

End Sub 

Function insert(PicPath, counter) 

    With ActiveSheet.Pictures.insert(PicPath) 


     With .ShapeRange 
      .LockAspectRatio = msoTrue 
      .Width = 50 
      .Height = 70 
     End With 
     .Left = ActiveSheet.Range("B" & counter).Left 
     .Top = ActiveSheet.Range("B" & counter).Top 
     .Placement = 1 
     .PrintObject = True 
    End With 
End Function 

課題は以下のとおりです。マクロの輸入 - この

指定したフォルダからのすべての画像。列Aで参照されている特定のピクチャのみが必要です。 - このマクロはすべてのピクチャを削除しますが、ボタンを保持します。

ご協力いただければ幸いです。

乾杯 G

Answer 1

はこのことを考えてみましょう。

Sub InsertPics() 
Dim fPath As String, fName As String 
Dim r As Range, rng As Range 

Application.ScreenUpdating = False 
fPath = "C:\Users\Public\Pictures\Sample Pictures\" 
Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row) 
i = 1 

For Each r In rng 
    fName = Dir(fPath) 
    Do While fName <> "" 
     If fName = r.Value Then 
      With ActiveSheet.Pictures.Insert(fPath & fName) 
       .ShapeRange.LockAspectRatio = msoTrue 
       Set px = .ShapeRange 
       If .ShapeRange.Width > Rows(i).Columns(2).Width Then .ShapeRange.Width = Columns(2).Width 
        With Cells(i, 2) 
         px.Top = .Top 
         px.Left = .Left 
         .RowHeight = px.Height 
        End With 
      End With 
     End If 
     fName = Dir 
    Loop 
    i = i + 1 
Next r 
Application.ScreenUpdating = True 
End Sub 

注：あなたは、このような「JPG」などのファイル拡張子を、必要とする、または使用しているものは何でも、あなたがそれに一致させることができます。