如何从含文件路径与指定位置的表格插入并动态调整图片

问题背景 #

需要实现以下功能：

• 用户在「Data Entry」工作表中维护表格，每行包含两项：图片文件路径（如P:\Phone Camera Dump\20121224_111617.jpg）、图片在「PICS」工作表中的放置区域
• 执行程序后，将图片插入「PICS」的指定区域，动态调整尺寸：当前固定区域为624px宽、374px高，支持解锁宽高比适配区域尺寸
• 现有代码使用静态行号定位图片，需修改为读取「Data Entry」中指定的单元格区域

修改后的VBA代码 #

Sub InsertImagesToTargetAreas()
    Dim picPath As String
    Dim targetAreaAddr As String
    Dim targetRange As Range
    Dim wsData As Worksheet, wsPics As Worksheet
    Dim dataRow As Long
    Dim insertingPic As Picture
    
    ' 初始化工作表对象
    Set wsData = ThisWorkbook.Worksheets("Data Entry")
    Set wsPics = ThisWorkbook.Worksheets("PICS")
    
    ' 遍历Data Entry中的数据行（假设从第13行开始，到第42行结束，C列存路径，D列存目标区域地址）
    For dataRow = 13 To 42
        picPath = wsData.Cells(dataRow, "C").Value
        targetAreaAddr = wsData.Cells(dataRow, "D").Value
        
        ' 跳过空路径或空区域的行
        If picPath = "" Or targetAreaAddr = "" Then GoTo NextRow
        
        ' 解析目标区域（支持直接写PICS工作表的单元格地址，如"C2"或"C2:D6"）
        On Error Resume Next
        Set targetRange = wsPics.Range(targetAreaAddr)
        On Error GoTo 0
        If targetRange Is Nothing Then GoTo NextRow
        
        ' 插入图片
        Set insertingPic = wsPics.Pictures.Insert(picPath)
        
        ' 设置图片属性：适配目标区域
        With insertingPic
            ' 解锁宽高比，允许自由调整
            .ShapeRange.LockAspectRatio = msoFalse
            ' 按固定尺寸设置（624px宽，374px高），若要适配目标区域实际大小，替换为下面两行注释的代码
            .Width = 624
            .Height = 374
            ' .Width = targetRange.Width
            ' .Height = targetRange.Height
            ' 对齐目标区域左上角
            .Top = targetRange.Top
            .Left = targetRange.Left
        End With
        
NextRow:
        Set targetRange = Nothing
        Set insertingPic = Nothing
    Next dataRow
    
    ' 激活PICS工作表
    wsPics.Activate
End Sub

代码关键修改说明 #

• 数据读取逻辑：遍历「Data Entry」的13-42行，同时读取C列的图片路径和D列的目标区域地址（支持单个单元格或单元格区域地址，如C2或C2:D6）
• 区域解析：通过wsPics.Range(targetAreaAddr)将文本格式的区域地址转换为实际Range对象，跳过无效或空的区域
• 图片适配：
  • 解锁宽高比（msoFalse），允许图片自由拉伸适配区域
  • 默认使用固定尺寸624px宽/374px高，若要适配目标区域的实际大小，可注释掉固定尺寸代码，启用targetRange.Width和targetRange.Height
• 定位逻辑：将图片左上角与目标区域的左上角对齐，确保放置位置准确

使用说明 #

1. 在「Data Entry」工作表的C13:C42填写图片完整路径，D13:D42填写「PICS」工作表中的目标区域地址（如C2或C2:D6）
2. 执行宏InsertImagesToTargetAreas即可完成图片插入与适配

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