批量提取文档特定字段内容到excel里
最近有个同事需要整理很多个word文档，需要把对应字段下面的段落（表格和表格编号）誊到excel里，做成一个总表。
她的想法是一个个打开复制粘贴。让我们帮忙的时候是这么说的。
我的想法是既然是固定字段的，那么可以转到excel里，按规律提取，不是更快一点吗。
写了一段代码实现了一下。前面的文档转txt，txt转excel，网上有现成的——感谢伟大无私的网友，祝你们年年有钱。
来源网址：https://blog.csdn.net/pijianzhirui/article/details/78668695
'docx转pdf、doc、rtf、txt
Option Explicit
Sub docx2other()
On Error Resume Next
Dim sEveryFile As String, sSourcePath As String, sNewSavePath As String
Dim CurDoc As Object
sSourcePath = "C:\Users\20201228\"
'假定待转换的docx文件全部在"E:\DOCX文件\"下，你需要按实际情况修改。
sEveryFile = Dir(sSourcePath & "*.docx")
Do While sEveryFile <> ""
Set CurDoc = Documents.Open(sSourcePath & sEveryFile, , , , , , , , , , , msoFalse)
sNewSavePath = VBA.Strings.Replace(sSourcePath & sEveryFile, ".docx", ".txt")
'如果想导出doc/rtf/txt等，就把上一行行尾的pdf换成doc/rtf/txt
'转化后的文件也在"E:\DOCX文件\"下，当然你可以按需修改。
CurDoc.SaveAs2 sNewSavePath, wdFormatText
'pdf对应wdFormatPDF,doc对应wdFormatDocument,rtf对应wdFormatRTF,txt对应wdFormatText
'更多格式可参见文末的截图WdSaveFormat Enumeration
CurDoc.Close SaveChanges:=False
sEveryFile = Dir
Loop
Set CurDoc = Nothing
End Sub
下面是将txt转成excel代码：
Sub Macro1()
'注意这个程序转txt文档受到上一次转文档设置影响。如果转的不符合心意，需要自行设置一下。
Dim p$, f$
Application.ScreenUpdating = False
Application.DisplayAlerts = False
p = ThisWorkbook.Path & "\"
f = Dir(p & "*.txt")
Do While f <> ""
Workbooks.OpenText p & f
With ActiveWorkbook
.SaveAs Filename:=p & Replace(f, ".txt", ".xlsx"), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
.Close
End With
f = Dir
Loop
Application.ScreenUpdating = True
End Sub
转完之后根据特定字段的行列号，批量复制内容导总表就行了。这个是自己写的。
Sub tiqu()
'把每个记录表的9 记录和10流程图之间的数据拷贝到此表格sheets（1）中
Application.ScreenUpdating = False
Set fso = CreateObject("scripting.filesystemobject")
Set ff = fso.getfolder(ThisWorkbook.Path)
a = 1
For Each f In ff.Files
If Right(f.Name, 4) = "xlsx" Then
Set wb = Workbooks.Open(f)
With wb
With .Worksheets(1)
For i = 1 To 500
If Left(.Cells(i, 1), 1) = 9 And .Cells(i, 1) Like "*记录*" Then
m = i
Exit For
End If
Next
For j = 600 To 1 Step -1
If Left(.Cells(j, 1), 2) = 10 And .Cells(j, 1) Like "*流程图*" Then
n = j
Exit For
End If
Next
.Range(.Cells(m, 1), .Cells(n, 1)).Copy Destination:=ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(a, 1), ThisWorkbook.Sheets(1).Cells(n - m + a, 1))
ThisWorkbook.Sheets(1).Range(ThisWorkbook.Sheets(1).Cells(a, 2), ThisWorkbook.Sheets(1).Cells(n - m + a, 2)) = f.Name
a = n - m + a + 1
End With
.Close savechanges:=True
End With
End If
Next
Application.ScreenUpdating = True
End Sub
这样运行一下，内容就在excel里了，剩下的工作就是简单整理一下即可。
