Sub test() Dim fso, fp, arr, wd, f, n%, fname$ Set fso = CreateObject("scripting.filesystemobject") Set fp = fso.getfolder(ThisWorkbook.Path) ReDim arr(1 To fp.Files.Count, 1 To 2) arr(1, 1) = "檔案號": arr(1, 2) = "標題" Set wd = CreateObject("word.application") n = 1 For Each f In fp.Files If Right(f, 3) = "doc" Or Right(f, 4) = "docx" Then n = n + 1: arr(n, 1) = fso.getbasename(f) fname = fso.getfilename(f) With wd.Documents.Open(ThisWorkbook.Path & "\" & fname, True, True) wd.Visible = True arr(n, 2) = .Paragraphs(2).Range .Close End With End If Next wd.Quit Sheets(1).[a1].Resize(UBound(arr), UBound(arr, 2)) = arrEnd Sub現在有一個資料夾下有N個Word檔案，要將他們的檔名和文件內的第二段提取到Excel表格，如何透過VBA實現
Sub test() Dim fso, fp, arr, wd, f, n%, fname$ Set fso = CreateObject("scripting.filesystemobject") Set fp = fso.getfolder(ThisWorkbook.Path) ReDim arr(1 To fp.Files.Count, 1 To 2) arr(1, 1) = "檔案號": arr(1, 2) = "標題" Set wd = CreateObject("word.application") n = 1 For Each f In fp.Files If Right(f, 3) = "doc" Or Right(f, 4) = "docx" Then n = n + 1: arr(n, 1) = fso.getbasename(f) fname = fso.getfilename(f) With wd.Documents.Open(ThisWorkbook.Path & "\" & fname, True, True) wd.Visible = True arr(n, 2) = .Paragraphs(2).Range .Close End With End If Next wd.Quit Sheets(1).[a1].Resize(UBound(arr), UBound(arr, 2)) = arrEnd Sub現在有一個資料夾下有N個Word檔案，要將他們的檔名和文件內的第二段提取到Excel表格，如何透過VBA實現