要将几百个word文件里的页眉和正文第一行的内容汇总到一个Excel

xzcdcak · 发表于 2024-5-26 23:54

同一个目录下有几百个格式相同的word文件，要把页眉里的红字部分（字母和数字组合，前面五个字母全都一样，后面数字会变化）如果不方便区分，就把页眉全贴过来也行，和黄字部分（每个word文件的正文的第一行），全部导出到excel里。word里红字放在红色单元格，word黄色部分放到黄色单元格。见附件。
先谢谢了。

longwin · 发表于 2024-5-27 01:13

taller · 发表于 2024-5-27 02:50

Option Explicit
Sub ProcessWordDocs()
Dim fso As Object
Dim folder As Object
Dim file As Object
Dim wordApp As Object
Dim wordDoc As Object
Dim Header As Object
Dim firstMatch As String
Dim firstParagraph As String
Dim ws As Worksheet
Dim row As Long
Application.ScreenUpdating = False
Set fso = CreateObject("Scripting.FileSystemObject")
Set folder = fso.GetFolder(ThisWorkbook.Path)
Set wordApp = CreateObject("Word.Application")
wordApp.Visible = False
Set ws = ThisWorkbook.Sheets("记录格式")
row = 3
For Each file In folder.Files
If LCase(file.Name) Like "*.doc" Then
Set wordDoc = wordApp.Documents.Open(file.Path)
For Each Header In wordDoc.Sections(1).Headers
With Header.Range.Find
.ClearFormatting
.Text = "TZBBB-*{5}"
.MatchWildcards = True
.Execute
If .Found Then
firstMatch = .Parent.Text
Exit For
End If
End With
Next Header
If wordDoc.Paragraphs.Count > 0 Then
firstParagraph = wordDoc.Paragraphs(1).Range.Text
Else
firstParagraph = "No Paragraphs"
End If
ws.Cells(row, 3).Value = firstMatch
ws.Cells(row, 2).Value = firstParagraph
wordDoc.Close SaveChanges:=False
row = row + 1
End If
Next file
wordApp.Quit
Application.ScreenUpdating = True
Set wordDoc = Nothing
Set wordApp = Nothing
Set file = Nothing
Set folder = Nothing
Set fso = Nothing
End Sub

复制代码

LIUZHU · 发表于 2024-5-27 10:17

Excel操做word，不常用基本上代码全忘了

dragonthree · 发表于 2024-5-27 11:04

taller 发表于 2024-5-27 02:50

学习下WORDVBA

usedrange · 发表于 2024-5-27 12:43

参与一下

Sub t()
Dim word, doc, obj, pro, fs, mpath, k, s, txt, fso, f, r%
mpath = ThisWorkbook.Path & "" & "示例"
Set pro = CreateObject("winmgmts:\\.\root\cimv2")
Set obj = pro.execquery("select * from win32_process")
Set fso = CreateObject("scripting.FileSystemObject")
Set fs = fso.getfolder(mpath).Files
'如果有winword.exe进程，则kill掉
For Each k In obj
If k.Name = "WINWORD.EXE" Then Shell "cmd.exe /c taskkill /f /t /pid " & k.processID
Next k
r = 3
For Each f In fs
If Not f.Name Like "~*" Then
If Split(f, ".")(1) = "doc" Then
Set word = CreateObject("Word.Application")
Set doc = word.Documents.Open(mpath & "" & f.Name)
fs = doc.sections(1).headers(1).Range
s = Split(fs, " ")
txt = Split(doc.Content.Text, " ")
With Sheet2
.Cells(r, "a") = r - 2
.Cells(r, "b") = txt(LBound(txt))
.Cells(r, "c") = s(UBound(s))
r = r + 1
End With
doc.Close
word.Quit
End If
End If
Next f
Set doc = Nothing
Set word = Nothing
Set obj = Nothing
Set pro = Nothing
Set fso = Nothing
End Sub

复制代码

gwjkkkkk · 发表于 2024-5-27 19:17

Option Explicit
Sub test()
Dim wdApp As Object, strFileName$, strPath$
Dim ar$(), br, vResult(), i&, j&, r&

strPath = ThisWorkbook.Path & "\"
strFileName = Dir(strPath & "*.doc")
Do Until strFileName = ""
      r = r + 1
      ReDim Preserve ar(1 To r)
      ar(r) = strPath & strFileName
      strFileName = Dir
Loop

If r = 0 Then MsgBox "未发现word文件！": Exit Sub
ReDim vResult(1 To UBound(ar), 1 To 3)

Application.ScreenUpdating = False
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err <> 0 Then
      Set wdApp = CreateObject("Word.Application")
End If

r = 0
For i = 1 To UBound(ar)
      With wdApp.Documents.Open(ar(i))
         r = r + 1
         With .Sections(1).Headers(1).Range
            br = Split(.Text)
            For j = 1 To UBound(br)
                  If Len(br(j)) Then vResult(r, 3) = br(j): Exit For
            Next j
         End With
         vResult(r, 2) = .Paragraphs(1).Range.Text
         vResult(r, 1) = r
         .Close False
      End With
Next i

[A1].CurrentRegion.Offset(2).ClearContents
[A3].Resize(r, 3) = vResult
If Err <> 0 Then wdApp.Quit
Set wdApp = Nothing
Application.ScreenUpdating = True
Beep
End Sub

gwjkkkkk · 发表于 2024-5-27 19:18

参与一下。。。

wanao2008 · 发表于 2024-5-27 20:59

usedrange 发表于 2024-5-27 12:43
参与一下

收藏你的代码了。
改为：
txt = Split(doc.Content.Text, vbCr)

更完美！！

xzcdcak · 发表于 2024-6-10 21:30

wanao2008 发表于 2024-5-27 20:59
收藏你的代码了。
改为：
txt = Split(doc.Content.Text, vbCr)

感谢。感谢各位的努力。谢谢。

		自动登录	找回密码
密码			免费注册

[求助] 要将几百个word文件里的页眉和正文第一行的内容汇总到一个Excel

评分

评分