Question

我正在尝试创建一个宏，它在工作表的A列中获取图像链接，粘贴相关图像，然后更改每行的行高以匹配该行中图片的高度。

我得到了粘贴部分，但无法弄清楚如何设置rowheight。我已经尝试了十几种不同的方法，但继续得到“无法设置Range类的RowHeight属性”错误。这是代码。

Sub ConvertLinktoImage()
Application.ScreenUpdating = False

Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row

Dim LastCell As String
LastCell = "A" & LastRow

Dim ImageHeight As Long
Dim RowRange As Range
Set RowRange = ActiveSheet.Range("A1:" & LastCell)

Dim ImageShape As Shape

For Each cell In RowRange
    filenam = cell.Value
    ActiveSheet.Pictures.Insert(filenam).Select
    Set ImageShape = Selection.ShapeRange.Item(1)
    ImageHeight = ImageShape.Height
    With ImageShape
        .LockAspectRatio = msoTrue
        .Cut
    End With

    Cells(cell.Row, cell.Column).PasteSpecial
    cell.RowHeight = ImageHeight
Next cell

Application.ScreenUpdating = True
End Sub

感谢您的帮助！

Answer 1

这应该有效

cell.EntireRow.RowHeight = ImageHeight

而不是

cell.RowHeight = ImageHeight

解释原因？
您根本无法更改单个单元格的高度，而是整行的高度。

Answer 2

请尝试以下代码，请记住最大RowHeight为409.5。

注意：我已删除了一些不必要的变量，并按照您设置ImageShape的方式进行了一些更改。我还建议您将ActiveSheet更改为完全限定的Worksheets("YourSheetName")。

<强>代码

Option Explicit

Sub ConvertLinktoImage()

Application.ScreenUpdating = False

Dim LastRow As Long
LastRow = Cells(Rows.Count, 1).End(xlUp).Row

Dim ImageHeight As Long
Dim RowRange As Range
Set RowRange = ActiveSheet.Range("A1:A" & LastRow)

Dim ImageShape As Object
Dim cell As Range
Dim filenam As String

For Each cell In RowRange
    filenam = cell.Value

    Set ImageShape = ActiveSheet.Pictures.Insert(filenam)
    With ImageShape
        If .Height > 409 Then .Height = 409 ' < maximum supported row height is 409.5
        ImageHeight = .Height
        .ShapeRange.LockAspectRatio = msoTrue
        .Cut
    End With

    cell.PasteSpecial
    cell.EntireRow.RowHeight = ImageHeight
Next cell

Application.ScreenUpdating = True
End Sub

VBA将行高限制为粘贴图像大小

2 个答案: