如何通过VBA调整含图片的指定单元格大小并嵌入图片至单个单元格？

针对你的需求，我们需要修改代码实现仅调整含图片的单元格大小，并确保图片完全嵌入该单元格内，具体修改如下：

1. 修正代码中的变量错误 #

原代码里定义了valor23但实际使用的是valor3，会导致编译错误，先修正：

' 原错误代码
' Dim valor23 As Variant
' 修正为
Dim valor3 As Variant

2. 移除全局单元格尺寸设置 #

删除原代码中对所有单元格设置行高列宽的语句，因为我们只需要调整存放图片的单个单元格：

' 删除以下两行
' nuevaHoja.Cells.RowHeight = 30
' nuevaHoja.Cells.ColumnWidth = 100

3. 调整图片所在单元格的大小并嵌入图片 #

在添加图片前，先设置目标单元格的行高和列宽，同时将图片的尺寸与单元格绑定，确保图片不会溢出。修改后的核心代码片段如下：

' 定位存放图片的单元格
Dim imgCell As Range
Set imgCell = nuevaHoja.Cells(fila, 1)

' 设置该单元格的大小（可根据需要调整数值）
imgCell.RowHeight = 100 ' 行高设为适配图片的高度
imgCell.ColumnWidth = 25 ' 列宽设为适配图片的宽度（注意：ColumnWidth单位与像素不同，可按需微调）

' 添加图片并设置属性
With nuevaHoja.Shapes.AddPicture(Filename:=imageURL, _
    LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
    Left:=imgCell.Left, Top:=imgCell.Top, Width:=imgCell.Width, Height:=imgCell.Height)
    .Placement = xlMoveAndSize ' 设置图片随单元格移动和调整大小
End With
fila = fila + 1

完整修改后的代码 #

Sub obtenerValores()
    ' Definir la tabla a iterar
    Dim tbl As ListObject
    Set tbl = ThisWorkbook.Worksheets("Hoja2").ListObjects("TableTest")

    ' Definir la nueva hoja para almacenar los valores
    Dim nuevaHoja As Worksheet
    Set nuevaHoja = ThisWorkbook.Worksheets.Add

    ' Definir la primera fila de la nueva hoja para escribir los valores
    Dim fila As Long
    fila = 1
    
    ' Iterar sobre las filas de la tabla
    Dim i As Long
    For i = 1 To tbl.ListRows.Count
        ' Obtener los valores de las celdas de la fila actual
        Dim valor1 As Variant
        valor1 = tbl.DataBodyRange(i, 1).Value
        
        Dim valor2 As Variant
        valor2 = tbl.DataBodyRange(i, 2).Value
        
        ' 修正变量名错误
        Dim valor3 As Variant
        valor3 = tbl.DataBodyRange(i, 3).Value
        
        Dim valor4 As Variant
        valor4 = tbl.DataBodyRange(i, 5).Value
        
        Dim imageURL As Variant
        imageURL = "P:\00_PlanesyProgramas\JavierEstrada\2023\01_PDU_EstructuraVial\PropuestaAnexo\Secciones PNG\" & valor3 & ".png"
        
        ' Escribir los valores en la nueva hoja
        nuevaHoja.Cells(fila, 1).Value = valor1
        nuevaHoja.Cells(fila, 1).HorizontalAlignment = xlCenter
        fila = fila + 1

        nuevaHoja.Cells(fila, 1).HorizontalAlignment = xlCenter
        
        ' 处理图片单元格和图片嵌入
        Dim imgCell As Range
        Set imgCell = nuevaHoja.Cells(fila, 1)
        ' 设置单元格大小适配图片
        imgCell.RowHeight = 100
        imgCell.ColumnWidth = 25
        
        ' 添加图片并绑定到单元格
        With nuevaHoja.Shapes.AddPicture(Filename:=imageURL, _
            LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
            Left:=imgCell.Left, Top:=imgCell.Top, Width:=imgCell.Width, Height:=imgCell.Height)
            .Placement = xlMoveAndSize
        End With
        fila = fila + 1
        

        nuevaHoja.Cells(fila, 1).Value = valor2
        nuevaHoja.Cells(fila, 1).HorizontalAlignment = xlCenter
        fila = fila + 1
        
        nuevaHoja.Cells(fila, 1).Value = valor4
        nuevaHoja.Cells(fila, 1).HorizontalAlignment = xlCenter
        fila = fila + 2
        
        ' 仅设置第一列的默认列宽（非图片单元格）
        nuevaHoja.Columns(1).ColumnWidth = 70
    Next i
End Sub

关键修改说明 #

• 仅调整目标单元格大小：通过imgCell.RowHeight和imgCell.ColumnWidth单独设置存放图片的单元格尺寸，避免影响其他单元格。
• 图片与单元格绑定：设置Placement = xlMoveAndSize后，图片会随单元格的移动或大小调整自动适配，确保始终在单元格内。
• 图片尺寸匹配单元格：添加图片时直接使用单元格的Width和Height作为图片尺寸，避免图片溢出。

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