Установите размер ячейки равным размеру изображения

Question

Я пытаюсь импортировать изображение в ячейку Excel, и у меня возникают проблемы с изменением размера.

Шаги:

1. Копирование / вставка изображения в ячейку
2. Изменение размера изображения вручную
3. А также изменение размера ячейки для фиксации на изображении.

Есть ли другой способ сделать это вместо того, чтобы вручную?

Answer 1

Это идет в другую сторону.

Мы вставим 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 2

Этот код изменит размер ячейки для вашей фотографии

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

Answer 3

Я не уверен, что именно вы имели в виду, изменив размер изображения вручную, но может ли это сработать для вас?

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 is409
• Макс. Ширина столбца 255