我看了你现有的代码片段，已经有了处理单ID图片的基础，现在只需要把固定ID改成动态变量，加上遍历Excel中OBJECTID的逻辑，就能实现批量关联插入的功能。下面是完整的实现方案：

整体实现思路 #

• 从Excel表格中提取所有OBJECTID列的唯一值（避免重复处理同一ID的图片）
• 遍历每个ID，在指定文件夹中筛选以该ID开头的.jpg图片
• 自动打开（或新建）Word文档，插入对应ID的房产信息（地址、描述）和匹配到的所有图片
• 处理完成后自动保存Word文档（可选）

完整VBA代码 #

Sub ExportPropertyWithImagesToWord()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim idRange As Range
    Dim currentID As Variant
    Dim uniqueIDs As Collection
    Dim i As Long
    
    ' Word对象变量
    Dim wordApp As Object
    Dim wordDoc As Object
    
    ' 文件系统对象变量
    Dim fso As Object
    Dim objFolder As Object
    Dim objFile As Object
    
    ' 路径设置（请修改为你的实际路径）
    Dim imgPath As String
    Dim saveWordPath As String
    imgPath = "C:\Users\xxx\你的图片文件夹路径\" ' 存放图片的文件夹
    saveWordPath = "C:\Users\xxx\生成的Word文档路径\房产信息文档.docx" ' 最终Word保存路径
    
    ' --------------------------
    ' 1. 读取Excel中的OBJECTID列并去重
    ' --------------------------
    Set ws = ThisWorkbook.Worksheets("Sheet1") ' 修改为你的表格工作表名
    lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' 假设OBJECTID在A列，根据实际调整
    Set idRange = ws.Range("A2:A" & lastRow) ' 假设第一行是表头，从第二行开始
    
    Set uniqueIDs = New Collection
    On Error Resume Next ' 捕获重复ID的错误，实现去重
    For Each currentID In idRange
        If Not IsEmpty(currentID.Value) Then
            uniqueIDs.Add currentID.Value, Key:=CStr(currentID.Value)
        End If
    Next currentID
    On Error GoTo 0
    
    ' --------------------------
    ' 2. 初始化Word应用
    ' --------------------------
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = True ' 设为False可以后台运行，不显示Word窗口
    Set wordDoc = wordApp.Documents.Add ' 新建文档，也可以打开已有文档：wordApp.Documents.Open("路径")
    
    ' --------------------------
    ' 3. 遍历每个唯一ID，匹配图片并插入Word
    ' --------------------------
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(imgPath) Then
        MsgBox "图片文件夹路径不存在，请检查！", vbExclamation
        GoTo Cleanup
    End If
    Set objFolder = fso.GetFolder(imgPath)
    
    For Each currentID In uniqueIDs
        ' 插入房产信息（假设地址在B列，描述在C列，根据实际调整）
        With wordDoc.Content
            .InsertAfter "房产ID: " & currentID & vbCrLf
            .InsertAfter "地址: " & ws.Cells(ws.Range("A:A").Find(currentID).Row, "B").Value & vbCrLf
            .InsertAfter "描述: " & ws.Cells(ws.Range("A:A").Find(currentID).Row, "C").Value & vbCrLf
            .InsertAfter "------------------------" & vbCrLf & vbCrLf
        End With
        
        ' 查找并插入当前ID对应的所有图片
        Dim imgCount As Integer
        imgCount = 0
        For Each objFile In objFolder.Files
            ' 动态匹配以当前ID开头的jpg图片
            If UCase(objFile.Name) Like CStr(currentID) & "_*.JPG" Then
                imgCount = imgCount + 1
                ' 插入图片到Word
                wordDoc.Content.InsertAfter "图片" & imgCount & ":" & vbCrLf
                wordDoc.InlineShapes.AddPicture _
                    FileName:=objFile.Path, _
                    LinkToFile:=False, _
                    SaveWithDocument:=True
                wordDoc.Content.InsertAfter vbCrLf & vbCrLf
            End If
        Next objFile
        
        ' 如果当前ID没有匹配到图片，提示说明
        If imgCount = 0 Then
            wordDoc.Content.InsertAfter "⚠️ 未找到对应图片" & vbCrLf & vbCrLf
        End If
    Next currentID
    
    ' --------------------------
    ' 4. 保存并整理Word文档
    ' --------------------------
    wordDoc.SaveAs2 FileName:=saveWordPath, FileFormat:=wdFormatXMLDocument ' 保存为docx格式
    MsgBox "处理完成！已生成Word文档：" & saveWordPath, vbInformation
    
Cleanup:
    ' 释放对象，避免内存泄漏
    Set objFile = Nothing
    Set objFolder = Nothing
    Set fso = Nothing
    Set wordDoc = Nothing
    ' 如果不需要保留Word窗口，可以关闭：wordApp.Quit
    Set wordApp = Nothing
    Set uniqueIDs = Nothing
    Set idRange = Nothing
    Set ws = Nothing
End Sub

关键代码解释 #

1. OBJECTID去重：使用Collection的Key属性实现自动去重，避免重复处理同一个ID的图片
2. 动态图片匹配：用CStr(currentID) & "_*.JPG"代替固定的66_*，实现根据当前ID动态筛选图片
3. Word插入逻辑：先插入房产的文字信息，再逐个插入匹配到的图片，同时处理无图片的情况给出提示
4. 错误处理与资源释放：添加了文件夹存在性检查，最后统一释放所有对象，避免VBA进程残留

使用注意事项 #

• 请根据你的实际表格结构修改代码中的列号（比如OBJECTID所在列、地址列、描述列）
• 务必修改imgPath和saveWordPath为你自己的实际文件路径
• 如果需要处理已有Word文档，把wordApp.Documents.Add改成wordApp.Documents.Open("你的已有文档路径")
• 如果不需要显示Word窗口，把wordApp.Visible = True改成False

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