加载图像以适合合并的单元格

Question

我有一个包含文件路径的table，单击按钮时宏将根据url路径显示图像。这是我的代码（来源：Link）

Sub Macro_1()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
On Error Resume Next
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("C5:D6, G5:H6, C8:D9, G8:H9")
For Each cell In xRange
    cName = cell
    ActiveSheet.Pictures.insert(cName).Select
    Set cShape = Selection.ShapeRange.Item(1)
    If cShape Is Nothing Then GoTo line22
    cColumn = cell.Column
    Set cRange = Cells(cell.Row, cColumn)
    With cShape
          .LockAspectRatio = msoFalse
            .Height = cRange.Height - 5
            .Width = cRange.Width - 5
            .Top = cRange.Top + 2
            .Left = cRange.Left + 2
            .Placement = xlMoveAndSize

    End With
line22:
        Set cShape = Nothing
    Next
    Application.ScreenUpdating = True
End Sub

代码如下图所示。

但我希望图像出现在所有合并的单元格中。如下图所示

如果您发现任何可以解决此问题的方法，请告诉我！我确定这很简单，但我已经在这个问题上停留了一段时间。

Answer 1

您可以使用Range对象的MergeArea 属性来return合并范围。你的宏可以修改如下（未测试）。 . .

Sub Macro_1()
Dim cShape As Shape
Dim cRange As Range
Dim cColumn As Long
On Error Resume Next
Application.ScreenUpdating = False
Set xRange = ActiveSheet.Range("C5, G5, C8, G8")
For Each cell In xRange
    cName = cell
    ActiveSheet.Pictures.Insert(cName).Select
    Set cShape = Selection.ShapeRange.Item(1)
    If cShape Is Nothing Then GoTo line22
    cColumn = cell.Column
    Set cRange = cell.MergeArea
    With cShape
          .LockAspectRatio = msoFalse
            .Height = cRange.Height - 5
            .Width = cRange.Width - 5
            .Top = cRange.Top + 2
            .Left = cRange.Left + 2
            .Placement = xlMoveAndSize

    End With
line22:
        Set cShape = Nothing
    Next
    Application.ScreenUpdating = True
End Sub

加载图像以适合合并的单元格

Load image to fit in merged cell

excel

vba