Excel批量导入图片

jpj123

详见附件      

jpj123

开心妙妙 发表于 2015-4-3 09:30
把myPath 变量用你指定的路径代替就可以了，例如这样：E:\用宏批量导入相片\"

这样通用性较差，写好 ...

1. Sub 批量导入相片jpj123()
   
2.     Dim i, myPath$, a1, a2, b1, b2
   
3.     Dim Pa As Picture, FD As FileDialog
   
4.     Set FD = Application.FileDialog(msoFileDialogFolderPicker)
   
5.     If FD.Show = -1 Then myPath = FD.SelectedItems(1) & ""
   
6.     'myPath = ThisWorkbook.Path & "" '获取当前文件的路径
   
7.     Application.ScreenUpdating = False
   
8.     For Each Pa In ActiveSheet.Pictures
   
9.         Pa.Delete
   
10.     Next
    
11.    
    
12.     For i = 2 To 11
    
13.         a1 = 0: a2 = 0: b1 = 0: b2 = 0
    
14.         Range("C" & i).Select
    
15.         a1 = ActiveCell.Left
    
16.         a2 = ActiveCell.Top
    
17.         b1 = ActiveCell.Width
    
18.         b2 = ActiveCell.Height
    
19.         ActiveSheet.Pictures.Insert(myPath & Range("A" & i).Value & ".jpg").Select
    
20.         Selection.ShapeRange.LockAspectRatio = False
    
21.         Selection.ShapeRange.Left = a1 + 1
    
22.         Selection.ShapeRange.Top = a2 + 1
    
23.         Selection.ShapeRange.Width = b1 - 2
    
24.         Selection.ShapeRange.Height = b2 - 2
    
25.     Next i
    
26.     Application.ScreenUpdating = True
    
27.     MsgBox "完成!"
    
28. End Sub
    
29. 
    

复制代码

jpj123

请测试附件   

605751967

Sub bmj()
Dim s As Shape, rg As Range
For Each s In ActiveSheet.Shapes
  
   s.Delete
  
Next s
Rows("1:50").RowHeight = 80
    Columns("b:b").ColumnWidth = 25
For Each rg In Range("b1:b" & Range("a1").End(xlDown).Row)
  ActiveSheet.Shapes.AddShape(msoShapeRectangle, rg.Left, rg.Top, rg.Width, rg.Height).Select
  Selection.ShapeRange.Fill.UserPicture "E:\图片111\" & rg.Offset(0, -1) & ".jpg"
Next
End Sub

中国AK47

jpj123 发表于 2015-9-28 14:02
在楼主代码的基础上修改了一下，实现了自动导入图片并指定了图片的位置和大小。

正好在找这个。太好用了。谢谢。尤其是大小也可以调整。方便。

likewinlike

jpj123 发表于 2015-9-28 14:02
在楼主代码的基础上修改了一下，实现了自动导入图片并指定了图片的位置和大小。

程序很棒，但是如果有一行没有对应的图片，此行后面的图片也无法插入，还请问这个问题怎么解决？

jpj123

likewinlike 发表于 2015-10-20 16:28
程序很棒，但是如果有一行没有对应的图片，此行后面的图片也无法插入，还请问这个问题怎么解决？

请测试代码：

1. Sub 批量导入相片jpj123()
   
2.     Dim i, myPath$, a1, a2, b1, b2, n%
   
3.     Dim Pa As Picture, FD As FileDialog
   
4.     n = Sheets("Sheet1").Range("A65536").End(3).Row
   
5.     Set FD = Application.FileDialog(msoFileDialogFolderPicker)
   
6.     If FD.Show = -1 Then myPath = FD.SelectedItems(1) & ""
   
7.     'myPath = ThisWorkbook.Path & "" '获取当前文件的路径
   
8.     Application.ScreenUpdating = False
   
9.     For Each Pa In ActiveSheet.Pictures
   
10.         Pa.Delete
    
11.     Next
    
12.      On Error GoTo X
    
13.     For i = 2 To n
    
14.         a1 = 0: a2 = 0: b1 = 0: b2 = 0
    
15.         Range("C" & i).Select
    
16.         a1 = ActiveCell.Left
    
17.         a2 = ActiveCell.Top
    
18.         b1 = ActiveCell.Width
    
19.         b2 = ActiveCell.Height
    
20.         ActiveSheet.Pictures.Insert(myPath & Range("A" & i).Value & ".jpg").Select
    
21.         Selection.ShapeRange.LockAspectRatio = False
    
22.         Selection.ShapeRange.Left = a1 + 1
    
23.         Selection.ShapeRange.Top = a2 + 1
    
24.         Selection.ShapeRange.Width = b1 - 2
    
25.         Selection.ShapeRange.Height = b2 - 2
    
26. X:
    
27.     Next i
    
28.     Application.ScreenUpdating = True
    
29.     MsgBox "完成!"
    
30. End Sub
    
31. 
    

复制代码

jpj123

详见附件：      

likewinlike

jpj123 发表于 2015-10-20 16:41
请测试代码：

OK,搞定，多谢！

23号人生

很强大，顶一下！