Excel精英培训网

 找回密码
 注册

QQ登录

只需一步,快速开始

你正在寻找更好的Excel学习教程吗?Excel技巧80集+数据透视表+函数初中高全套+VBA80集,想学的这儿全都有
查看: 135|回复: 6
打印 上一主题 下一主题

[已解决] 将文件夹中图片粘贴到EXCEL中不显示

[复制链接]
跳转到指定楼层
1楼
发表于 2020-4-2 11:20 | 只看该作者 回帖奖励 |倒序浏览 |阅读模式
excel精英培训的微信平台,每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
求助各位大神:选择文件夹与要粘贴的单元格,文件夹中图片名字与EXCEL单元格对应粘贴,运行完写的粘贴成功可是图片不显示是怎么回事啊

Sub InsertPic()
Dim Arr, i&, k&, n&, pd&
Dim PicName$, PicPath$, FdPath$, shp As Shape
Dim Rng As Range, Cll As Range, Rg As Range, book$
On Error Resume Next

With Application.FileDialog(msoFileDialogFolderPicker) '用户选择图片所在的文件夹
.AllowMultiSelect = False  '不允许多选
If .Show Then FdPath = .SelectedItems(1) Else: Exit Sub
End With

If Right(FdPath, 1) <> "\" Then FdPath = FdPath & "\"
Set Rng = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8)   '用户选择需要插入图片的名称所在单元格范围
Set Rng = Intersect(Rng.Parent.UsedRange, Rng)    'intersect语句避免用户选择整列单元格,造成无谓运算的情况
If Rng Is Nothing Then MsgBox "选择的单元格范围不存在数据!": Exit Sub


Application.ScreenUpdating = False
Rng.Parent.Select

Arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")      '用数组变量记录五种文件格式

For Each Cll In Rng     '遍历选择区域的每一个单元格
PicName = Cll.Text   '图片名称
If Len(PicName) Then   '如果单元格存在值
PicPath = FdPath & PicName    '图片路径
pd = 0    'pd变量标记是否找到相关图片
For i = 0 To UBound(Arr)   '由于不确定用户的图片格式,因此遍历图片格式
If Len(Dir(PicPath & Arr(i))) Then  '如果存在相关文件

1:ActiveSheet.Pictures.Paste(PicPath & Arr(i)).Select '插入图片并选中
2:ActiveSheet.Pictures(PicPath & Arr(i)).Select
    Selection.Copy
    ActiveSheet.Pictures.Paste:

With Selection
.ShapeRange.LockAspectRatio = msoFalse  '撤销锁定纵横比
.Top = Cll.Offset(x, y).Top + 5
.Left = Cll.Offset(x, y).Left + 5
.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

MsgBox "共处理成功" & n & "个图片,另有" & k & "个非空单元格未找到对应的图片。"
Application.ScreenUpdating = True
End Sub

            






分享到:  QQ好友和群QQ好友和群
收藏收藏
2楼
 楼主| 发表于 2020-4-2 11:50 | 只看该作者
之前是插入图片,用的这个函数'ActiveSheet.Pictures.Insert(PicPath & Arr(i)).Select '插入图片并选中
因为插入图片的文件夹中图片不能删除,所以想改为粘贴
回复

使用道具 举报

3楼
发表于 2020-4-2 21:14 | 只看该作者
既然不要纵横比,就不要用insert,直接addpicture就可以了。
添加图片后不会因为源文件的消失而消失。
附件简单示例,解压到同一个路径下执行。

test.zip

20.49 KB, 下载次数: 5

回复

使用道具 举报

4楼
 楼主| 发表于 2020-4-3 08:34 | 只看该作者
大灰狼1976 发表于 2020-4-2 21:14
既然不要纵横比,就不要用insert,直接addpicture就可以了。
添加图片后不会因为源文件的消失而消失。
附 ...

还是不显示哦,附件上传不了,可以麻烦您试一下嘛,感谢

Sub InsertPic()


Dim Arr, i&, k&, n&, pd&
Dim PicName$, PicPath$, FdPath$, shp As Shape
Dim Rng As Range, Cll As Range, Rg As Range, book$
On Error Resume Next

With Application.FileDialog(msoFileDialogFolderPicker) '用户选择图片所在的文件夹
.AllowMultiSelect = False  '不允许多选
If .Show Then FdPath = .SelectedItems(1) Else: Exit Sub
End With

If Right(FdPath, 1) <> "\" Then FdPath = FdPath & "\"
Set Rng = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8)   '用户选择需要插入图片的名称所在单元格范围
Set Rng = Intersect(Rng.Parent.UsedRange, Rng)    'intersect语句避免用户选择整列单元格,造成无谓运算的情况
If Rng Is Nothing Then MsgBox "选择的单元格范围不存在数据!": Exit Sub

Application.ScreenUpdating = False
Rng.Parent.Select
Arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")      '用数组变量记录五种文件格式

For Each Cll In Rng     '遍历选择区域的每一个单元格
PicName = Cll.Text   '图片名称
If Len(PicName) Then   '如果单元格存在值
PicPath = FdPath & PicName    '图片路径
pd = 0    'pd变量标记是否找到相关图片
For i = 0 To UBound(Arr)   '由于不确定用户的图片格式,因此遍历图片格式
If Len(Dir(PicPath & Arr(i))) Then  '如果存在相关文件
'ActiveSheet.Pictures.Insert(PicPath & Arr(i)).Select '插入图片并选中
'Selection.Copy
''Selection.Delete
'ActiveSheet.Pictures.Paste


'ActiveSheet.Pictures.Copy(PicPath & Arr(i)).Select '插入图片并选中
'ActiveSheet.Pictures.Paste(PicPath & Arr(i)).Select '插入图片并选中
'ActiveSheet.Range(PicPath & Arr(i)).Select
'    Selection.Cut
'    Range(PicPath & Arr(i)).Select
'    ActiveSheet.Pictures.Paste.Select
'
'
' Set Selection = ActiveSheet.Shapes.AddShape(msoShapeRectangle, 40, 120, 280, 30)
' ActiveSheet.Shapes.AddPicture PicPath, True, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height


With Selection
ActiveSheet.Shapes.AddPicture PicPath, True, True, Rng.Left, Rng.Top, Rng.Width, Rng.Height
'.ShapeRange.LockAspectRatio = msoFalse  '撤销锁定纵横比
'.Top = Cll.Offset(x, y).Top + 5
'.Left = Cll.Offset(x, y).Left + 5
'.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

MsgBox "共处理成功" & n & "个图片,另有" & k & "个非空单元格未找到对应的图片。"
Application.ScreenUpdating = True

End Sub

            

文件夹中放图片以表格中1(1)命名就好




回复

使用道具 举报

5楼
发表于 2020-4-3 08:43 | 只看该作者
附件上传不了,有提示吗
回复

使用道具 举报

6楼
 楼主| 发表于 2020-4-3 08:46 | 只看该作者
爱疯 发表于 2020-4-3 08:43
附件上传不了,有提示吗

对的,写的内部服务器错误。
代码是可以直接运行的,需要把图片命名为1(1)然后放在文件夹中,选择文件夹就可以。
现在就是除了Insert方法,addshape/paste都写的图片导入成功但是不显示,麻烦帮忙看看

回复

使用道具 举报

7楼
 楼主| 发表于 2020-4-3 09:57 | 只看该作者
好了好了,是参数没有设置好,感谢帮助
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2020-4-28 06:21 , Processed in 0.062400 second(s), 5 queries , Gzip On, Redis On.

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

快速回复 返回顶部 返回列表
拼三张下载