如何把文件夹所有图片复制到EXECL2007表中

nexca

         求救我有A，B，C，D，E四个文件夹，里面有图片，现在需要A，B，C，D所有的图片复制到A，B，C，D各个EXECL2007表中，如何用VBA写

jok22

1. Sub InsertPicture()
   
2.     Dim MyShape As Shape
   
3.     Dim r As Integer
   
4.     Dim c As Integer
   
5.     Dim PicPath As String
   
6.     Dim Picrng As Range
   
7.     Dim d As Date
   
8.     With Sheet1
   
9.         For Each MyShape In .Shapes
   
10.             If MyShape.Type = 13 Then
    
11.                 MyShape.Delete
    
12.             End If
    
13.         Next
    
14.         For r = 7 To .Cells(.Rows.Count, 7).End(xlUp).Row Step 10
    
15.             For c = 6 To 6
    
16.                 PicPath = ThisWorkbook.Path & "" & .Cells(r, c).Text & ".jpg"
    
17.                 If Dir(PicPath) <> "" Then
    
18.                     Set MyShape = .Shapes.AddPicture(PicPath, False, True, 250, 250, 250, 250)
    
19.                     .Cells(r - 4, c) = findpicdate(PicPath)
    
20.                     Set Picrng = .Range(Cells(r - 4, c - 4), Cells(r + 1, c - 4))
    
21.                     With MyShape
    
22.                         .LockAspectRatio = msoFalse
    
23.                         .Top = Picrng.Top + 1.5
    
24.                         .Left = Picrng.Left + 1.5
    
25.                         .Width = Picrng.Width - 1.5
    
26.                         .Height = Picrng.Height - 1.5
    
27.                         .TopLeftCell = ""
    
28.                     End With
    
29.                 Else
    
30.                     .Cells(r - 4, c - 4) = "暂无照片"
    
31.                     .Cells(r - 4, c) = ""
    
32.                 End If
    
33.             Next
    
34.         Next
    
35.     End With
    
36.     Set MyShape = Nothing
    
37.     Set Picrng = Nothing
    
38. End Sub
    
39. Sub MyName()
    
40.     Dim MyName As String
    
41.     Dim r As Integer
    
42.     r = 7
    
43.     MyName = Dir(ThisWorkbook.Path & "" & "*.jpg")
    
44.     Do While MyName <> ""
    
45.         If MyName <> ".jpg" And MyName <> ".." Then
    
46.             Cells(r, 6) = MyName
    
47.             r = r + 10
    
48.             Else
    
49.             Cells(r, 6).ClearContents
    
50.         End If
    
51.         MyName = Dir
    
52.     Loop
    
53.      Cells.Replace What:=".jpg", Replacement:="", LookAt:=xlPart, SearchOrder _
    
54.         :=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    
55. End Sub

复制代码

没有附件。这是一个我写的从文件夹导入图片的代码，要插入的单元格自己改吧！

nexca

Sub MyName()这里是不是输入A文件夹路径？

nexca

JOK22，我还有点不明白，希望你的帮忙，谢谢！