设置单元格大小等于图片大小答案

【问题标题】：Set cell size equal to picture size设置单元格大小等于图片大小
【发布时间】：2019-02-22 13:32:31
【问题描述】：

我正在尝试将图片导入 Excel 单元格，但我遇到了重新调整大小的问题。

步骤：

将图片复制/粘贴到单元格中
手动调整图片大小
并调整单元格的大小以固定在图片上。

除了手动，还有其他方法吗？

【问题讨论】：

标签： excel vba resize

【解决方案1】：

我不确定您手动调整图片大小的确切含义，但这可能对您有用吗？

Sub ResizeCells()

Dim X As Double, Y As Double, Z As Double
Dim s As Shape

For Each s In ActiveSheet.Shapes
    If s.Type = msoPicture Then
        For X = s.TopLeftCell.Column To s.BottomRightCell.Column
            Y = Y + ActiveSheet.Cells(1, X).ColumnWidth
        Next X
        For X = s.TopLeftCell.Row To s.BottomRightCell.Row
            Z = Z + ActiveSheet.Cells(1, X).RowHeight
        Next X
        s.TopLeftCell.ColumnWidth = Y
        s.TopLeftCell.RowHeight = Z
    End If
Next s

End Sub

注意：

最大行高为409
最大列宽为255

【讨论】：

【解决方案2】：

这是另一回事。

我们将从 Internet 插入一个Shape。
我们将把它移到单元格 B1。
我们将调整 Shape 的大小（高度和宽度） 以适合 B1

首先将此链接放在单元格 A1：

http://www.dogbreedinfo.com/images26/PugPurebredDogFawnBlackMax8YearsOld1.jpg

然后运行：

Sub MAIN()
    Call InstallPicture
    Call PlaceAndSizeShape
End Sub

Sub InstallPicture()
    Dim v As String

    v = Cells(1, 1).Value
    With ActiveSheet.Pictures
        .Insert (v)
    End With
End Sub

Sub PlaceAndSizeShape()
    Dim s As Shape, B1 As Range, w As Double, h As Double

    Set s = ActiveSheet.Shapes(1)

    s.Select
    Selection.ShapeRange.LockAspectRatio = msoFalse

    Set B1 = Range("B1")
    s.Top = B1.Top
    s.Left = B1.Left
    s.Height = B1.Height
    s.Width = B1.Width
End Sub

【讨论】：

【解决方案3】：

这篇文章很旧，但没有人提到调整图片大小以匹配单元格。

当我厌倦了使用@Andrew 的代码缩放宽度时，Excel 非常不可靠。幸运的是，rCell.Left 的单位正确。您可以使用以下方法获取实际的列宽：

rCell.Offset(0, 1).Left - rCell.Left

【讨论】：

【解决方案4】：

此代码将根据您的图片调整单元格的大小

Sub ResizePictureCells()
For Each Picture In ActiveSheet.DrawingObjects
PictureTop = Picture.Top
PictureLeft = Picture.Left
PictureHeight = Picture.Height
PictureWidth = Picture.Width
For N = 2 To 256
If Columns(N).Left > PictureLeft Then
PictureColumn = N - 1
Exit For
End If
Next N
For N = 2 To 65536
If Rows(N).Top > PictureTop Then
PictureRow = N - 1
Exit For
End If
Next N
Rows(PictureRow).RowHeight = PictureHeight
Columns(PictureColumn).ColumnWidth = PictureWidth * (54.29 / 288)
Picture.Top = Cells(PictureRow, PictureColumn).Top
Picture.Left = Cells(PictureRow, PictureColumn).Left
Next Picture
End Sub

【讨论】：