谁能帮我将若干word文档内所有页的第一行自动提取到一个exl表格内，所有word文档不需一一打开。

发布网友 发布时间：2022-04-23 09:35

我来回答

共3个回答

热心网友 时间：2023-10-09 16:15

你有类似的代码，应发出来参考。
我在网上查过，可以将资料发给你---来自“百度文档”的资料：
‘******************************************************************

批量获取word文档第一行作为文件名
此方法是用WORD宏的方法来实现 如果出现用户变量未定义请 在VB编辑器界面选择 工具引用 找到microsoft scripting runtime 貌似是这个， 选中再运行就ok了。News_Content为自定义替换字符。
Option Explicit
Dim arrFiles()
Dim cntFiles%

Sub Main()
Dim i%, StartFolder$, SavePath$
Dim fso As New FileSystemObject, fd As Folder
ReDim arrFiles(1 To 1000)
cntFiles = 0
StartFolder = "D:\Word" '原文件目录
SavePath ="D:\Word2" '改名后的文件目录
Set fd = fso.GetFolder(StartFolder)
SearchFiles fd
ReDim Preserve arrFiles(1 To cntFiles)
For i = 1 To cntFiles
RenameDocument arrFiles(i), SavePath, i
Next i
End Sub

Sub SearchFiles(ByVal fd As Folder)
Dim fl As File
Dim sfd As Folder
For Each fl In fd.Files
If LCase(Right(fl.Path, 4)) = ".doc" Then
cntFiles = cntFiles + 1
If cntFiles >=UBound(arrFiles) Then ReDim Preserve arrFiles(1 To cntFiles + 1000)
arrFiles(cntFiles) = fl.Path
End If
Next fl
If fd.SubFolders.Count = 0 Then Exit Sub
For Each sfd In fd.SubFolders
SearchFiles sfd
Next
End Sub

Sub RenameDocument(ByVal wordFileName, ByVal wordFilePath, ByVal num)
On Error Resume Next
Dim myTitle$, myFileName$
Dim mydoc As Document, myRange As Range
Dim News_Content
Set mydoc = Word.Documents.Add
mydoc.Activate
Selection.InsertFile FileName:=wordFileName,Range:="", ConfirmConversions:= _
False, Link:=False,Attachment:=False
ActiveWindow.View.Type = wdPageView
Set myRange = mydoc.Paragraphs.First.Range
myRange.SetRange myRange.Start, myRange.End - 1

News_Content = Trim(myRange.Text)
News_Content = Replace(News_Content, "！", "_")
News_Content = Replace(News_Content, "/", "")
News_Content = Replace(News_Content, "。", "")
News_Content = Replace(News_Content, " ", "")
News_Content = Replace(News_Content, "（", "")
News_Content = Replace(News_Content, "）", "")
News_Content = Replace(News_Content, "“", "")
News_Content = Replace(News_Content, "”", "")
News_Content = Replace(News_Content, " ", "")

myTitle = News_Content
If (myTitle = "") Or (Len(myTitle) > 50)Then
Debug.Print"ERR:--------------------------------------------" + wordFileName
Shell "cmd.exe /c echo" & "ERR:--------------------------------------------" &wordFileName & ">>D:\Word.log"
mydoc.CloseSaveChanges:=wdDoNotSaveChanges
SendKeys ("{ESC}")
Exit Sub
End If
myFileName = wordFilePath + "\" + myTitle +".doc"
mydoc.SaveAs myFileName
mydoc.Close SaveChanges:=wdDoNotSaveChanges
Debug.Print num & ":" & wordFileName& "=" & myFileName
Shell "cmd.exe /c echo " & num &":" & wordFileName & "=" & myFileName &">>D:\Word.log"
End Sub

热心网友 时间：2023-10-09 16:15

具个人所知，有点复杂，应该可以制作成软件了，宏的话解决不了吧。追问宏也可以解决
我有段类似的代码 你会修改吗？

热心网友 时间：2023-10-09 16:16

这个有点困难，还真是没涉及过