从本地文件夹导入特定的图片到Excel中

我对VBA是完全陌生的，在工作中遇到困难时，我正在混淆视听。

我正在寻找一个简单的代码来导入特定的图片从一个文件夹到工作表。 我真的很困扰编码语言，很多东西都在我的头上。

我基本上希望macros查看列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 

我遇到的挑战是：

– 这个macros导入给定文件夹中的所有图片。 我只想要列A中引用特定的图片。此macros删除所有图片，但我想保留button。

任何帮助，将不胜感激。

干杯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'，或者你正在使用的任何东西，所以你可以匹配。