EXCEL批量插入图片到指定单元格

baby_2023

求助：Excel中批量图片插入到对应的单元格中，如：以数字命名1~1000命令的图片需批量插入到已输入数字1~1000的1000个不规则排序的格子里，在线等，万分感谢！

astree

baby_2023 发表于 2024-1-20 21:06
可能是我没表述清楚，指定的单元图是不规则的排序，这里不能上传EXCEL文件，我做一下链接https://wwzg.lanz ...

已用你给的Excel做了测试，没啥大问题。参考我给出的vba脚本，假定了你的图片为png,如果不是请做对应修改，将Excel和图片放置于同一文件夹内，路径不要有中文空格等特殊字符。如何运行vba脚本：打开Excel 按下 Alt+F11 找到对应sheet，贴入代码，然后按F5执行

[Shell] 纯文本查看 复制代码

?

01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49

Sub InsertPicsWithMergedCells()     Dim Pic As Picture     Dim rng As Range     Dim path As String     Dim lastRow As Long     Dim lastColumn As Long     Dim picPath As String       '指定图片的路径     path = ThisWorkbook.path & "\"       '找到最后一行     lastRow = ActiveSheet.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row       '设定最后一列为 X 列的编号     lastColumn = Columns("X").Column       '添加错误处理     On Error GoTo ErrorHandler       '在表单的每个单元格里遍历     For Each rng In ActiveSheet.Range("A1:" & Cells(lastRow, lastColumn).Address)         '验证单元格内容是否是数字         If IsNumeric(rng.MergeArea(1, 1).Value) Then             '通过单元格中的文本找到图片文件的名称和路径             picPath = path & rng.MergeArea(1, 1).Value & ".png"             '检查文件是否存在             If Dir(picPath) <> "" Then                 '在单元格中插入图片                 Set Pic = ActiveSheet.Pictures.Insert(picPath)                 '确定图片的位置和大小                 With Pic                     .ShapeRange.LockAspectRatio = msoFalse                     .Width = rng.MergeArea.Width                     .Height = rng.MergeArea.Height                     .Top = rng.MergeArea.Top                     .Left = rng.MergeArea.Left                 End With                   '设置Pic为空，避免出现"对象变量未设置"的错误                 Set Pic = Nothing             End If         End If     Next rng     Exit Sub '退出子程序   ErrorHandler: '错误处理程序     MsgBox "Error occurred: " & Err.Description End Sub

vostro5

才疏学浅，图片不是漂浮的吗在excel里。不如说是你想要什么效果的东西，看看高手能不能通过其他操作实现

baby_2023

感谢回复，我现有1000张施工图片，需要插入到1000个不规则排序的单元格内，这1000个格子已输入了数字1——1000，我是想把对应的图片1嵌入到单元格1里面，以此累推，共1000个图片

lnxctz

问了下gpt3.5，他有答案啊，使用vba脚本，我没电脑，测试不了

vostro5

不好意思，还真有方法。不知道是不是你想要的。https://jingyan.baidu.com/article/f25ef25483a15f092d1b826d.html
http://www.360doc.com/content/16/0623/17/34544979_570185673.shtml
https://baijiahao.baidu.com/s?id=1694925012601689013&wfr=spider&for=pc

rq1338

https://www.bilibili.com/video/BV1JQ4y1T7j5/?spm_id_from=333.337.search-card.all.click&vd_source=ebd6a7e10c90b9637f78f5746dcaea59
用WPS的话看下面这个 以右键点击 转换为嵌入单元格图片，防止后续操作的时候图片乱跑

https://www.bilibili.com/video/BV18e411G7vM/?spm_id_from=333.788.recommend_more_video.0&vd_source=ebd6a7e10c90b9637f78f5746dcaea59

小小涩郎

写个VBA 就行了    图片在一个文件夹里就行

JackLei

放到excel vb运行窗口运行就行

[Visual Basic] 纯文本查看 复制代码

?

01 02 03 04 05 06 07 08 09 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82

Sub InsertPic()     Dim arr, i&, k&, n&, b As Boolean     Dim strPicName$, strPicPath$, strFdPath$, shp As Shape     Dim rngData As Range, rngEach As Range, rngWhere 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 rngData = Application.InputBox("请选择图片名称所在的单元格区域", Type:=8)     '用户选择需要插入图片的名称所在单元格范围     Set rngData = Intersect(rngData.Parent.UsedRange, rngData)     'intersect语句避免用户选择整列单元格，造成无谓运算的情况     If rngData 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 rngWhere = rngData.Offset(-y, 0)         Case "下"         Set rngWhere = rngData.Offset(y, 0)         Case "左"         Set rngWhere = rngData.Offset(0, -y)         Case "右"         Set rngWhere = rngData.Offset(0, y)     End Select     Application.ScreenUpdating = False     rngData.Parent.Parent.Activate '用户选定的激活工作簿     rngData.Parent.Select     For Each shp In ActiveSheet.Shapes     '如果旧图片存放在目标图片存放范围则删除         If Not Intersect(rngWhere, shp.TopLeftCell) Is Nothing Then shp.Delete     Next     x = rngWhere.Row - rngData.Row     y = rngWhere.Column - rngData.Column     '偏移的坐标     arr = Array(".jpg", ".jpeg", ".bmp", ".png", ".gif")     '用数组变量记录五种文件格式     For Each rngEach In rngData     '遍历选择区域的每一个单元格         strPicName = rngEach.Text         '图片名称         If Len(strPicName) Then         '如果单元格存在值             strPicPath = strFdPath & strPicName             '图片路径             b = False             '变量标记是否找到相关图片             For i = 0 To UBound(arr)             '由于不确定用户的图片格式，因此遍历图片格式                 If Len(Dir(strPicPath & arr(i))) Then                 '如果存在相关文件                     Set shp = ActiveSheet.Shapes.AddPicture( _                         strPicPath & arr(i), False, True, _                         rngEach.Offset(x, y).Left + 5, _                         rngEach.Offset(x, y).Top + 5, _                         20, 20)                     shp.Select                     With Selection                         .ShapeRange.LockAspectRatio = msoFalse                         '撤销锁定图片纵横比                         .Height = rngEach.Offset(x, y).Height - 10 '图片高度                         .Width = rngEach.Offset(x, y).Width - 10 '图片宽度                     End With                     b = True '标记找到结果                     n = n + 1 '累加找到结果的个数                     Range("a1").Select: Exit For '找到结果后就可以退出文件格式循环                 End If             Next             If b = False Then k = k + 1 '如果没找到图片累加个数         End If     Next     Application.ScreenUpdating = True     MsgBox "共处理成功" & n & "个图片，另有" & k & "个非空单元格未找到对应的图片。" End Sub

房州波哥

vostro5 发表于 2024-1-20 14:51
才疏学浅，图片不是漂浮的吗在excel里。不如说是你想要什么效果的东西，看看高手能不能通过其他操作实现

wps的表格有个内嵌图片功能，然后，然后到微软表格里无法显示