Excel VBA自动调整图片大小以适应表格

Sub 调整图片大小() Dim Pic As Picture Dim Ws As Worksheet Dim LCell As Range Dim TCell As Range Dim RCell As Range Dim BCell As Range Dim PicWidth As Double Dim PicHeight As Double Dim CellWidth As Double Dim CellHeight As Double Dim WidthRatio As Double Dim HeightRatio As Double Dim Ratio As Double

Set Ws = ActiveSheet
Set Pic = Ws.Pictures('Picture1') '替换为你的图片名称
Set LCell = Ws.Range('A1')
Set TCell = Ws.Range('A1')
Set RCell = Ws.Range('A1')
Set BCell = Ws.Range('A1')

'获取图片大小
PicWidth = Pic.Width
PicHeight = Pic.Height

'获取表格范围
For Each Cell In Ws.UsedRange.Cells
    If Cell.Left < LCell.Left Then
        Set LCell = Cell
    End If
    If Cell.Top < TCell.Top Then
        Set TCell = Cell
    End If
    If Cell.Left + Cell.Width > RCell.Left + RCell.Width Then
        Set RCell = Cell
    End If
    If Cell.Top + Cell.Height > BCell.Top + BCell.Height Then
        Set BCell = Cell
    End If
Next Cell

'计算单元格大小
CellWidth = RCell.Left + RCell.Width - LCell.Left
CellHeight = BCell.Top + BCell.Height - TCell.Top

'计算宽高比
WidthRatio = PicWidth / CellWidth
HeightRatio = PicHeight / CellHeight

'选择比例较小的值作为缩放比例
If WidthRatio < HeightRatio Then
    Ratio = WidthRatio
Else
    Ratio = HeightRatio
End If

'调整图片大小
Pic.Width = PicWidth / Ratio
Pic.Height = PicHeight / Ratio

End Sub