使用VBA将特定照片从文件夹导入Excel

Question

我正在尝试使用VBA将图片导入Excel。我当前的代码允许用户选择图片所在的文件夹，然后将该文件夹中的所有图片导入到 Excel 中。我想保持文件夹选择过程相同，但仅导入选定的照片。所选照片将由我的电子表格一列中的照片名称确定。下面是我现有的代码。任何帮助将不胜感激。我不想将文件路径插入代码中。我希望用户选择文件所在的文件夹，并使用宏在该文件夹中搜索 A 列中的特定文件名，并将相应的图片插入到 Excel 中。

Sub InsertPictures()

    Dim myDialog As FileDialog, myFolder As String, myFile As String
    
    Set myDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    If myDialog.Show = -1 Then
        myFolder = myDialog.SelectedItems(1) & Application.PathSeparator
        myFile = Dir(myFolder)
        
        Do While myFile <> ""
        r = r + 2
        With Cells(r, 14)
            .RowHeight = 15
            x = .Left
            y = .Top
            w = .Width
            h = .Height
            
        End With
        
        myPicture = myFolder & myFile
        ActiveSheet.Shapes.AddPicture (myPicture), _
        msoFalse, msoTrue, x, y, w, h
        myFile = Dir
        
        Loop
        
    End If
    
End Sub

Answer 1

您没有回答我的澄清问题，所以我假设您在

picturesColumn

栏中有图片名称（不带扩展名）（我的代码中的“C”，根据您的需要更改它）：

Sub InsertPictures()
    Dim ws As Worksheet, lastR As Long, rngPict As Range, rngP As Range, cel As Range
    Dim myDialog As FileDialog, myFolder As String, myFile As String, myPicture As String
    Dim x As Single, y As Single, W As Single, h As Single
    Const picturesColumn As String = "C" 'the column keeping the pictures name list
    
    Set ws = ActiveSheet 'use here the sheet where you have the column/list of pictures name
    lastR = ws.cells(ws.rows.count, picturesColumn).End(xlUp).row 'last row on the column keeping pictures list
    Set rngPict = ws.Range(ws.cells(2, picturesColumn), ws.cells(lastR, picturesColumn)) 'the pictures range
    rngPict.EntireRow.RowHeight = 72 'set the whole range row height
    SetWidthHeightPoints 72, 72, 14  'set column (14) width equal to the rows height
    
    Set myDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    With myDialog
       .Title = "Select the folder where from to pick up the necessary pictures"
       .AllowMultiSelect = False
       If .Show <> -1 Then Exit Sub 'nothing has been selected...
       myFolder = .SelectedItems(1) & Application.PathSeparator
    End With
    
    'Iterate between each cell of pictures range and insert if picture exists in myFolder:
    For Each cel In rngPict.cells
        myFile = Dir(myFolder & cel.value & ".*") 'no need of extension in the cel.value...
        If myFile <> "" Then
            Set rngP = ws.cells(cel.row, 14)
            x = rngP.left 'place the picture in column N:N
            y = rngP.top
            W = rngP.width
            h = rngP.height
            
            myPicture = myFolder & myFile
            ws.Shapes.AddPicture (myPicture), msoFalse, msoTrue, x, y, W, h
        End If
    Next cel
    MsgBox "Ready..."
End Sub