Importieren von bestimmten Bildern in Excel aus dem lokalen Ordner

Question

Ich bin völlig neu in VBA und ich muddle meinen Weg durch eine Herausforderung bei der Arbeit.

Ich bin auf der Suche nach einem einfachen Code, um bestimmte Bilder aus einem Ordner in ein Arbeitsblatt zu importieren. Ich habe wirklich mit der Programmiersprache zu kämpfen und viel geht mir über den Kopf.

Ich möchte im Grunde, dass das Makro alle Referenzen in Spalte A betrachtet und das zugehörige Bild aus einem Ordner auf meinem Laufwerk in die angrenzende Spalte zurückgibt. Die Referenz in Spalte A ist der Dateiname ohne die Erweiterung.

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 

Die Herausforderungen, die ich habe, sind:

-Diese Makro importiert alle Bilder aus den angegebenen Ordner. Ich möchte nur bestimmte Bilder in Spalte A verwiesen. -Dieses Makro löscht alle Bilder, aber ich möchte Tasten behalten.

Jede Hilfe wäre willkommen.

Prost G

Answer 1

das Betrachten.

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 

Hinweis: Sie müssen die Dateierweiterung, wie ‚jpg‘, oder was auch immer Sie verwenden, damit Sie sich auf die mithalten können.