如何通过VBA按Excel列中指定文件名导入指定文件夹图片

核心调整说明 #

• 保留原文件夹选择流程，全程不硬编码文件路径
• 遍历Excel表格A列的文件名（默认从A2开始，A1视为表头）
• 在用户选定的文件夹内匹配对应文件，找到则按原逻辑插入到第14列位置
• 增加文件存在性校验，避免因缺失文件导致代码中断

完整修改代码 #

Sub InsertPicturesByFilename()
    Dim myDialog As FileDialog, myFolder As String
    Dim fileNameRange As Range, cell As Range
    Dim picturePath As String
    Dim r As Long, x As Single, y As Single, w As Single, h As Single
    
    r = 0 ' 初始化行号，与原代码逻辑对齐
    
    ' 弹出文件夹选择对话框
    Set myDialog = Application.FileDialog(msoFileDialogFolderPicker)
    If myDialog.Show = -1 Then
        myFolder = myDialog.SelectedItems(1) & Application.PathSeparator
        
        ' 定义A列需匹配的文件名范围（从A2到最后一个非空单元格）
        Set fileNameRange = ThisWorkbook.ActiveSheet.Range("A2:A" & ThisWorkbook.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row)
        
        ' 遍历每个文件名
        For Each cell In fileNameRange
            If cell.Value <> "" Then
                r = r + 2
                ' 获取插入位置的坐标与尺寸（沿用原代码第14列的设置）
                With Cells(r, 14)
                    .RowHeight = 15
                    x = .Left
                    y = .Top
                    w = .Width
                    h = .Height
                End With
                
                picturePath = myFolder & cell.Value
                
                ' 检查文件是否存在，存在则插入图片
                If Dir(picturePath) <> "" Then
                    ActiveSheet.Shapes.AddPicture _
                        Filename:=picturePath, _
                        LinkToFile:=msoFalse, _
                        SaveWithDocument:=msoTrue, _
                        Left:=x, Top:=y, Width:=w, Height:=h
                Else
                    ' 文件不存在时在对应单元格提示
                    Cells(r, 14).Value = "未找到文件: " & cell.Value
                End If
            End If
        Next cell
    End If
    
    ' 释放对象
    Set myDialog = Nothing
    Set fileNameRange = Nothing
End Sub

' 原Word文档生成代码保留（如需调整可单独修改）
Sub WordDocumentText()
    Dim wdApp As Word.Application
    
    Set wdApp = New Word.Application
    
    With wdApp
        .Visible = True
        .Activate
        
        .Documents.Add
        
        With .Selection
            .ParagraphFormat.Alignment = wdAlignParagraphCenter
            .ParagraphFormat.SpaceAfter = 0
            .Font.Name = "Times New Roman"
            .Font.Size = 12
            .TypeText (ThisWorkbook.Sheets("Sheet1").Cells(2, 10).Text)
            .TypeText (ThisWorkbook.Sheets("Sheet1").Cells(2, 11).Text)
            .TypeText (ThisWorkbook.Sheets("Sheet1").Cells(2, 12).Text)
            .TypeText (ThisWorkbook.Sheets("Sheet1").Cells(2, 2).Text)
            .TypeText ". "
            .TypeText (ThisWorkbook.Sheets("Sheet1").Cells(3, 2).Text)
            .TypeParagraph
            .TypeParagraph
            
        End With
        
    End With
            
End Sub

使用注意事项 #

1. A列需填写带扩展名的完整文件名（例如logo.png、product.jpg）
2. 运行InsertPicturesByFilename宏，选择图片所在文件夹即可自动匹配插入
3. 若文件不存在，对应单元格会显示提示文本，不会中断宏运行

内容的提问来源于stack exchange，提问作者Kyle Anderson