感謝會飛的魚大牛~

 1 Public fp$, obmapp As Object
 2 Sub kk()
 3 文件夾瀏覽器
 4 Application.ScreenUpdating = False
 5 Set fso = CreateObject("scripting.filesystemobject")
 6 If fp = "" Then Exit Sub
 7 Set ff = fso.getfolder(fp)
 8 For x = 1 To 17
 9     Documents.Add DocumentType:=wdNewBlankDocument
10     For
 
 Each fd In ff.subfolders
11         t = Int(fd.Files.Count / 17)
12         For y = 1 To t
13             Selection.InlineShapes.AddPicture FileName:=fd & "\" & x * t - t + y & ".png", LinkToFile:=False, SaveWithDocument:=True
14             Selection.TypeParagraph
15             Selection.TypeText Text:=fd.Name & "
 
_" & Format(x * t - t + y, "00") & Chr(13)
16         Next
17     Next
18     Selection.WholeStory
19     Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
20     
21     ‘替換名稱中的+為/
22     Selection.Find.ClearFormatting
23     Selection.Find.Replacement.ClearFormatting
24     With Selection.Find
 
25         .Text = "+"
26         .Replacement.Text = "/"
27         .Forward = True
28         .Wrap = wdFindContinue
29         .Format = False
30         .MatchCase = False
31         .MatchWholeWord = False
32         .MatchByte = True
33         .MatchWildcards = False
34         .MatchSoundsLike = False
35         .MatchAllWordForms = False
36     End With
37     Selection.Find.Execute Replace:=wdReplaceAll
38     ‘上面是錄制的宏
39     ActiveDocument.SaveAs2 FileName:=fp & "\" & x & ".docx"
40     ActiveWindow.Close
41 Next
42 Application.ScreenUpdating = True
43 End Sub
44 Sub 文件夾瀏覽器()
45     Set obmapp = CreateObject("Shell.Application").BrowseForFolder(0, "請選擇文件目錄：", 0, 0)
46     If Not obmapp Is Nothing Then
47         fp = obmapp.Self.Path & ""
48     Else
49         Exit Sub
50     End If
51 End Sub

VBA批量導入圖片到多Word文檔並加標題（會飛的魚）