[已解决]如何按名为100个工作簿在相同位置插入100张图片？

lingyuncelia1

哪位大神可以赐教一下？如果有100个工作簿，每个工作簿分别叫1、2、3、……，且每个工作簿都只有一张工作表，也叫1、2、3、……，另有100张图片，每张图片也叫1、2、3、……，在每个工作簿的工作表的I1分别按自己的名字插入同名的图片，哪位大神可以提供个方便的方法啊？

最佳答案

月排行榜 / 总排行榜

dsmch

2016-3-25 14:32

1. Sub Macro1()
   
2. mypath = ThisWorkbook.Path & ""
   
3. wj = Dir(mypath & "*.xls")
   
4. Application.ScreenUpdating = False
   
5. Do While wj <> ""
   
6.    If wj <> ThisWorkbook.Name Then
   
7.         With Workbooks.Open(mypath & wj)
   
8.             ActiveSheet.DrawingObjects.Delete
   
9.             x = [i1].Left: y = [i1].Top
   
10.             w = [i1].Width: h = [i1].Height
    
11.             ActiveSheet.Shapes.AddShape(msoShapeRectangle, x, y, w, h).Select
    
12.             Selection.ShapeRange.Fill.UserPicture mypath & "" & Split(wj, ".xls")(0) & ".jpg"
    
13.             .Close True
    
14.         End With
    
15.    End If
    
16.    wj = Dir
    
17. Loop
    
18. MsgBox "插入图片完毕"
    
19. Application.ScreenUpdating = True
    
20. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. mypath = ThisWorkbook.Path & ""
   
3. wj = Dir(mypath & "*.xls")
   
4. Application.ScreenUpdating = False
   
5. Do While wj <> ""
   
6.    If wj <> ThisWorkbook.Name Then
   
7.         With Workbooks.Open(mypath & wj)
   
8.             ActiveSheet.DrawingObjects.Delete
   
9.             x = [i1].Left: y = [i1].Top
   
10.             w = [i1].Width: h = [i1].Height
    
11.             ActiveSheet.Shapes.AddShape(msoShapeRectangle, x, y, w, h).Select
    
12.             Selection.ShapeRange.Fill.UserPicture mypath & "" & Split(wj, ".xls")(0) & ".jpg"
    
13.             .Close True
    
14.         End With
    
15.    End If
    
16.    wj = Dir
    
17. Loop
    
18. MsgBox "插入图片完毕"
    
19. Application.ScreenUpdating = True
    
20. End Sub

复制代码

dsmch

………………

lingyuncelia1

dsmch 发表于 2016-3-25 14:34
………………

这个代码写得真好，我发表问题后自行百度过。有N种解答的方法，但都比您的代码逊色。您的像诗歌那样有美感，简洁、高效。