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

我试图创build一个工作表的A列中的图像链接的macros，粘贴关联的图像，然后更改每行的行高度以匹配该行中的图片的高度。

我得到了粘贴部分，但无法弄清楚如何设置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。

注意 ：我已经删除了一些不必要的variables，并改变了你设置ImageShape 。 我还build议将您的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