VBA匹配行高度粘贴图像大小

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