当前位置:首页 > VBA&EXCEL > 批量将图片插入到表格中?So Easy!

批量将图片插入到表格中?So Easy!

九天狼5年前 (2019-05-24)VBA&EXCEL2918

天天我等着你等着你捉泥鳅 大哥哥好不好咱们去捉泥鳅……

[aplayer url="http://rr03.sycdn.kuwo.cn/872f98ac705fee2c92997ac112b3a890/5ce7d83e/resource/a1/86/29/2835338402.aac" pic="http://star.kuwo.cn/star/starheads/180/53/67/755582100.jpg" autoplay="false"/]

直接说正事,咱们今天分享的内容是按指定名称和位置批量将图片插入到Excel工作表中……

看个动画先:


代码如下

Sub InsertPic()
    'ExcelHome VBA编程学习与实践 by:看见星光
    Dim Arr, i&, k&, n&, pd&
    Dim strPicName$, strPicPath$, strFdPath$, shp As Shape
    Dim Rng As Range, Cll As Range, Rg As Range, strWhere As String
    'On Error Resume Next
    '用户选择图片所在的文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
       If .Show Then strFdPath = .SelectedItems(1) Else: Exit Sub
    End With
    If Right(strFdPath, 1) <> "\" Then strFdPath = strFdPath & "\"
    Set Rng = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8)
    '用户选择需要插入图片的名称所在单元格范围
    Set Rng = Intersect(Rng.Parent.UsedRange, Rng)
    'intersect语句避免用户选择整列单元格,造成无谓运算的情况
    If Rng Is Nothing Then MsgBox "选择的单元格范围不存在数据!": Exit Sub
    strWhere = InputBox("请输入图片偏移的位置,例如上1、下1、左1、右1", , "右1")
    '用户输入图片相对单元格的偏移位置。
    If Len(strWhere) = 0 Then Exit Sub
    x = Left(strWhere, 1)
    '偏移的方向
    If InStr("上下左右", x) = 0 Then MsgBox "你未输入偏移方位。": Exit Sub
    y = Val(Mid(strWhere, 2))
    '偏移的值
    Select Case x
        Case "上"
        Set Rg = Rng.Offset(-y, 0)
        Case "下"
        Set Rg = Rng.Offset(y, 0)
        Case "左"
        Set Rg = Rng.Offset(0, -y)
        Case "右"
        Set Rg = Rng.Offset(0, y)
    End Select
    Application.ScreenUpdating = False
    Rng.Parent.Select
    For Each shp In ActiveSheet.Shapes
    '如果旧图片存放在目标图片存放范围则删除
        If Not Intersect(Rg, shp.TopLeftCell) Is Nothing Then shp.Delete
    Next
    x = Rg.Row - Rng.Row
    y = Rg.Column - Rng.Column
    '偏移的坐标
    Arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")
    '用数组变量记录五种文件格式
    For Each Cll In Rng
    '遍历选择区域的每一个单元格
        strPicName = Cll.Text
        '图片名称
        If Len(strPicName) Then
        '如果单元格存在值
            strPicPath = strFdPath & strPicName
            '图片路径
            pd = 0
            'pd变量标记是否找到相关图片
            For i = 0 To UBound(Arr)
            '由于不确定用户的图片格式,因此遍历图片格式
                If Len(Dir(strPicPath & Arr(i))) Then
                '如果存在相关文件
                    Set shp = ActiveSheet.Shapes.AddPicture( _
                        strPicPath & Arr(i), False, True, _
                        Cll.Offset(x, y).Left + 5, _
                        Cll.Offset(x, y).Top + 5, _
                        20, 20)
                    shp.Select
                    With Selection
                        .ShapeRange.LockAspectRatio = msoFalse
                        '撤销锁定图片纵横比
                        .Height = Cll.Offset(x, y).Height - 10 '图片高度
                        .Width = Cll.Offset(x, y).Width - 10 '图片宽度
                    End With
                    pd = 1 '标记找到结果
                    n = n + 1 '累加找到结果的个数
                    [a1].Select: Exit For '找到结果后就可以退出文件格式循环
                End If
            Next
            If pd = 0 Then k = k + 1 '如果没找到图片累加个数
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "共处理成功" & n & "个图片,另有" & k & "个非空单元格未找到对应的图片。"
End Sub

代码已有注释说明,这儿就再说明一下运行过程。

首先,会让用户选择存放图片的文件夹。注意是选择文件夹,不是选择图片;选择文件夹后,看不到文件夹内的图片是正常现象。

然后,选择图片名称存放的单元格区域,可以选择整列、多列、整行或多行,比如示例动画中的B:D列,2:2行等。。

最后,设置图片相对于图片名称所在的单元格便宜的位置;比如图片名称在B列,图片放在C列,那就是向右偏移1列,即右1。上下左右代表了方向,数字代表偏移的量。

代码继续运行,先删除存放于放置图片单元格范围的原图片图形(如何用代码删除指定位置的图形图片?这个问题也不要在后台提问了),然后遍历图片名称,根据偏移位置插入新图片。

代码运行结束后会告之用户一共成功插入了多少张图片,以及失败了多少张;有朋友说找不到图片的单元格能否填充颜色作提醒,我想想觉得没必要啊,就没做……不要说我懒,认真脸。

小贴士:

1,该段小代码支持一下图片格式:

".jpg", ".jpeg", ".bmp", ".png", ".gif"

2,图片的纵横比是未锁定的,如需锁定,可以注释掉下句代码:

.ShapeRange.LockAspectRatio = msoFalse

3,图片的行高和列宽是由放置图片的单元格行高和列宽决定的。当然,您也可以把代码稍微修改,设置固定的图片行高和列宽,并由图片的行高和列宽决定单元格的大小。

4,图片的名称必须和指定单元格范围内的名称一致,如果需要模糊匹配,使用DIR函数搭配通配符的方式即可。

5,代码采用非引用的方式插入图片,该方式会图片作为excel的资源打包到excel文件中,即便数据源的图片已被删除,表格中的图片也依然存在。

此处为隐藏内容,请评论后查看隐藏内容,谢谢!

如果内容对你有用,请花费几秒钟给个评论!

由于评论审核机制,可能您的评论暂时不可见,不影响查看回复可见的内容!

扫描二维码推送至手机访问。

版权声明:本文由云淡风轻Mr.Liu发布,如需转载请注明出处。

本文链接:http://www.nylmj.cn/post/100.html

相关文章

是时候制作一份自杀or杀人的工作簿了

是时候制作一份自杀or杀人的工作簿了

1,……Long Long Ago……山的那边海的那边……有位Excel高手……他在一家电子商务公司上班。他有一份Excel工作簿,通过VBA编程将日常工作通通自动化了。他每天闲的除了喝王者农药就是剁...

HI,你会用函数实现网页数据抓取吗?

HI,你会用函数实现网页数据抓取吗?

随着互联网的高速发展,网页数据愈发成为数据分析过程中最重要的数据来源之一。也许正是基于这样的考量,从2013版开始,Excel新增了一个名为Web的函数类别,使用其下的函数,可以通过网页链接从Web服...

不做加班狗——批量生成带照片的准考证

不做加班狗——批量生成带照片的准考证

Word提供的邮件合并功能可以帮助咱们轻松的制作工资条、通知书、邀请函、明信片、准考证、毕业证书等等,一般做法是用Word文档做一个模板,将信息的数据源存放到Excel表格里,通过邮件合并建立起表格与...

这个函数牛到不行了,7.53%的人竟然还不会用

这个函数牛到不行了,7.53%的人竟然还不会用

小伙伴们好啊,今天介绍一个还有7.53%的人不认识的函数:AGGREGATEAGGREGATE函数用法与SUBTOTAL函数类似,但在功能上比SUBTOTAL函数更加强大,不仅可以实现诸如SUM、AV...

【Excel VBA】批量将工作表转换为独立工作簿

【Excel VBA】批量将工作表转换为独立工作簿

有时候 有时候 我会相信一切有尽头……相聚离开都有时候 没有什么会永垂不朽……有时,我们需要将一个工作簿里的每一张工作表,另存为单独的工作薄;如果只是一两张工作表,我们手工操作就挺好的,可如果是若干张...

如何使用VBA代码将Word的表格批量写入Excel?

如何使用VBA代码将Word的表格批量写入Excel?

晚上好啊都……呃……不知道该说什么了,直接说正事吧……话说我最近比较懒……不是,我最近事情比较多……你们在后台提了很多问题,有一部分是我们之前分享过的,戳菜单【VBA相关】→【常用小代码】,可见详情;...

发表评论

访客

◎欢迎参与讨论,请在这里发表您的看法和观点。