EXCEL VBA 导入图片自适应大小

最新推荐文章于 2024-04-30 09:31:29 发布

原创最新推荐文章于 2024-04-30 09:31:29 发布 · 9.4k 阅读

3 ·

CC 4.0 BY-SA版权

文章标签：

#vba #excel #buffer #文档 #url #c

windows 专栏收录该内容

27 篇文章

订阅专栏

这是一个使用VBA宏在Excel中批量导入图片的代码示例，图片会根据单元格的大小自动调整尺寸。代码首先定义图片路径、目标列、图片宽高及表格宽高等参数，然后遍历指定范围的单元格，根据款号和颜色生成图片文件名，并插入图片。通过调整ShapeRange的Width和Height属性，使图片适应单元格尺寸。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

Sub into_pic()
On Error Resume Next '忽略错误继续执行VBA代码,避免出现错误消息

'图片路径
pic_url = "d:\我的文档\桌面\"
'图片所在的列
pic_column_num = "C"
'图片宽度
pic_width = 100
'图片高度
pic_height = 100
'表格宽度
Range_width = 22
'表格高度
Range_Height = 100

'款号所在起始的列
k_id_column_start_num = "A"
'颜色所在起始的列
k_color_column_start_num = "B"
'款号所在起始的行
k_id_column_start_row = 2

For i = k_id_column_start_row To 65535
buffer_val = Range(k_id_column_start_num & i).Value
buffer_color_val = Range(k_color_column_start_num & i).Value

If buffer_val <> "" Then
    ActiveSheet.Range(pic_column_num & i).Select
    pic_urls = pic_url & "\" & buffer_val & buffer_color_val & ".jpg"
        cColumn = ActiveCell.Column '所在列数

        rRow = ActiveCell.Row '所在行数

        'MsgBox (cColumn)
        'MsgBox (rRow)
    'Rows(i & ":" & i).RowHeight = Range_Height
    'Columns(pic_column_num & ":" & pic_column_num).ColumnWidth = Range_width
        ' With ActiveSheet.Pictures.Insert(pic_urls)
        With Sheets("Sheet1").Pictures.Insert(pic_urls) '可用
          .ShapeRange.LockAspectRatio = msoFalse
          .Placement = xlMoveAndSize
          '.ShapeRange.Top = Selection.Top
          '.ShapeRange.Left = Selection.Left

           .ShapeRange.Left = Range(pic_column_num & i).Left
           .ShapeRange.Top = Range(pic_column_num & i).Top
          '.ShapeRange.Width = pic_width
          '.ShapeRange.Height = pic_height
          '.ShapeRange.Height = Range(pic_column_num & i).Height
          .ShapeRange.Height = Range(pic_column_num & i).Height
          .ShapeRange.Width = Range(pic_column_num & i).Width

          ''''''''''''''''''''''''''
         '   Sub Test()
         '         With Sheets("Sheet1").Pictures.Insert("d:\我的文档\桌面\52058.JPG ") '可用
         '                   .ShapeRange.LockAspectRatio = msoFalse
         '                   .Placement = xlMoveAndSize
         '                   .ShapeRange.Left = Range("b2 ").Left
         '                   .ShapeRange.Top = Range("b2 ").Top
         '                   .ShapeRange.Height = Range("b2:b5 ").Height
         '                   .ShapeRange.Width = Range("b2:c2 ").Width
         '           End With
         '   End Sub

          ''''''''''''''''''''''''''

          End With

End If
Next i
End Sub

、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、、

早期的文件代码，不自动缩放

Sub into_pic()
On Error Resume Next '忽略错误继续执行VBA代码,避免出现错误消息

'图片路径
pic_url = "d:\我的文档\桌面\mu\pic"
'图片所在的列
pic_column_num = "C"
'图片宽度
pic_width = 100
'图片高度
pic_height = 100
'表格宽度
Range_width = 22
'表格高度
Range_Height = 100

'款号所在起始的列
k_id_column_start_num = "A"
'颜色所在起始的列
k_color_column_start_num = "B"
'款号所在起始的行
k_id_column_start_row = 2

For i = k_id_column_start_row To 65535
buffer_val = Range(k_id_column_start_num & i).Value
buffer_color_val = Range(k_color_column_start_num & i).Value

If buffer_val <> "" Then
    ActiveSheet.Range(pic_column_num & i).Select
    pic_urls = pic_url & "\" & buffer_val & buffer_color_val & ".jpg"
        cColumn = ActiveCell.Column
        rRow = ActiveCell.Row
         With ActiveSheet.Pictures.Insert(pic_urls)
          .Top = Selection.Top
          .Left = Selection.Left
          .ShapeRange.LockAspectRatio = msoFalse
          .ShapeRange.Width = pic_width
          .ShapeRange.Height = pic_height
          End With
    Rows(i & ":" & i).RowHeight = Range_Height
    Columns(pic_column_num & ":" & pic_column_num).ColumnWidth = Range_width
End If
Next i
End Sub