在Word文件中查找章节标题，并使用VBA将单个段落复制到新的Word文件中 [英] Finding heading of chapters in word file and copying individual paragraphs to new word file with VBA
问题描述
由于没有人能够帮助我解决我之前在这里发布的问题(链接在下面)，因此我现在正尝试通过VBA解决该任务.
Since nobody was able to help me with the problem I posted here before (link is below), I am now trying to solve the task through VBA.
查找Word文件中的标题，然后使用python将整个段落复制到新的Word文件中
为了简要地回顾一下，我有大量的word文件，我希望将每个word文件减小为可读性更好的文件.在每个文件中，一个标题会多次出现，并始终设置为标题2".我正在寻找一个在文档中多次出现的特定标题，我想将这些章节中的所有文本部分以及相应的标题复制到一个新的word文档中.
To briefly recap, I have a large amount of word files, which I would like to reduce to a more readable size each. In each file, there is one heading that appears several times, always formated as a 'Heading 2'. I look for this specific heading which occurs several times in a document and I want to copy all the text parts in just these chapters with the respective heading to a new word document.
我决定创建一个excel文件，在其中列出文件以及要复制的章节的相应标题(见下图).
I decided to create an excel file in which I list the files and the respective heading of the chapters that I want to copy (see picture below).
为此，我编写了以下代码:
To do this now I have written the following code:
Sub SelectData()
Application.ScreenUpdating = False
Dim WdApp As Word.Application
Set WdApp = CreateObject("Word.Application")
Dim Doc As Word.Document
Dim NewDoc As Word.Document
Dim HeadingToFind As String
Dim ChapterToFind As String
Dim StartRange As Long
Dim EndRange As Long
Dim WkSht As Worksheet
Dim LRow As Long
Dim i As Long
Set WkSht = ThisWorkbook.Sheets("Sheet1")
LRow = WkSht.UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
With WkSht
For i = 1 To LRow
If Dir(.Cells(i, 1).Text, vbNormal) = "" Then
.Cells(i, 3).Value = "Please check File Location"
Else
Set Doc = WdApp.Documents.Open(Filename:=.Cells(i, 1).Text, _
AddToRecentFiles:=False, Visible:=False, ReadOnly:=False)
Set NewDoc = Documents.Add
ChapterToFind = LCase(.Cells(i, 2).Text)
With Doc
Selection.HomeKey Unit:=wdStory
With Selection
With .Find
.ClearFormatting
.Text = ChapterToFind
.MatchWildcards = False
.MatchCase = True
.Execute
End With
If .Find.Found Then
.Collapse wdCollapseStart
With .Find
.Text = ""
.Style = "Heading 2"
.Forward = False
.Execute
End With
.MoveDown Count:=1
.HomeKey Unit:=wdLine
StartRange = .Start
.Find.Forward = True
.Find.Execute
.Collapse wdCollapseStart
.MoveUp Count:=1
.EndKey Unit:=wdLine
EndRange = .End
Doc.Range(StartRange, EndRange).Copy
NewDoc.Content.Paste
NewDoc.SaveAs2 Doc.Path & "Clean" & ".docx", wdFormatFlatXML
Else
WkSht.Cells(i, 4).Value = "Error Chapter Not Found"
End If
End With
End With
WdApp.Quit
Set Doc = Nothing: Set NewDoc = Nothing: Set WdApp = Nothing: Set WkSht = Nothing
Application.ScreenUpdating = True
End If
Next
End With
End Sub
但是我真的很挣扎.由于我不断出现命令错误(RunTimeError 438)，因此它似乎不起作用:
However I am really struggling. It seems to not work as I constantly get an error with the command (RunTimeError 438):
Selection.HomeKey Unit:=wdStory
我知道我必须激活参考中的Microsoft Word 15.0对象库才能获得Word命令.但是，它无法正常工作.
I am aware that I have to activate the Microsoft Word 15.0 Object Library in the references to be able to get word commands. Nevertheless it is not working.
我将非常感谢您的帮助，当然我也欢迎其他建议.
I would greatly appreciate any help, I am also open to other suggestions of course.
Word文件的外观类似于下图，但是我要提取的章节可能在一个Word文档中出现多次.结果，我的代码可能需要循环或其他操作，我无法完成此操作.
The word files look something like in the picture below, however the chapter that I want to extract can occur several times within one word document. As a result my code would probably need a loop or something, I was not able to get this done.
我还考虑了以下指向该主题的链接:
Also I have considered the following links to the topic:
推荐答案
我正确理解了吗?以下代码是我认为您要尝试执行的操作的核心.它找到第一个标题2，然后找到其后的所有段落，直到找到任何类型的另一个标题或文档的末尾. startCopyRange和endCopyRange是这些段落的范围.您必须将其放入Excel例程中.
Did I understand this correctly? The following code is the core of what I think you're trying to do. It finds the first Heading 2, then finds all the paragraphs after it until it finds another header of any type or the end of the document. startCopyRange and endCopyRange is the range of those paragraphs. You'll have to piece this into your Excel routine.
一些注意事项.始终将活动文档保存到变量中并从中进行操作；然后，用户可以在此例程运行时自由更改活动文档.永远不要使用选择，永远要使用范围.永远不要使用诸如Move之类的相对动作，总是使用API调用.
A few notes. Always save the active document to a variable and work from that; the user is then free to change active documents while this routine is running. Never use Selection, always use ranges. Never use relative movements like Move, always use API calls.
Sub SelectData()
Dim Doc As Word.Document
Set Doc = ActiveDocument
Dim findRange As Range
Set findRange = Doc.Range
ChapterToFind = "My Chapter"
findRange.Find.Text = ChapterToFind
findRange.Find.Style = "Heading 2"
findRange.Find.MatchCase = True
Dim startCopyRange As Long
Dim endCopyRange As Long
Do While findRange.Find.Execute() = True
startCopyRange = findRange.End + 1
endCopyRange = -1
'findRange.Select
Dim myParagraph As Paragraph
Set myParagraph = findRange.Paragraphs(1).Next
Do While Not myParagraph Is Nothing
myParagraph.Range.Select 'Debug only
If InStr(myParagraph.Style, "Heading") > 0 Then
endCopyRange = myParagraph.Range.Start - 0
End If
If myParagraph.Next Is Nothing Then
endCopyRange = myParagraph.Range.End - 0
End If
If endCopyRange <> -1 Then
Doc.Range(startCopyRange, endCopyRange).Select 'Debug only
DoEvents
Exit Do
End If
Set myParagraph = myParagraph.Next
DoEvents
Loop
Loop
End Sub
这篇关于在Word文件中查找章节标题，并使用VBA将单个段落复制到新的Word文件中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！
