设置像元大小等于图片大小

Question

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

步骤：

1. 将图片复制/粘贴到单元格
2. 手动调整图片大小
3. 还要调整单元格的大小以固定在图片上。

还有其他方法可以代替手动操作吗？

Answer 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

注意：

• 最大RowHeight为409
• 最大列宽为255

Answer 2

这是另一回事。

我们将从互联网上插入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

Answer 3

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

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