title: Finding heading of chapters in word file and copying individual paragraphs to new word file with VBA
body: <p>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.</p>
  
  <p><a href="https://stackoverflow.com/questions/47703796/finding-a-heading-in-word-file-and-copying-entire-paragraph-thereafter-to-new-wo">Finding a heading in word file and copying entire paragraph thereafter to new word file with python</a></p>
  
  <p>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.</p>
  
  <p>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).</p>
  
  <p><img src="https://i.stack.imgur.com/7kRq5.jpg" alt="Excel File with Matched Word Files and Chapter Keywords"></p>
  
  <p>To do this now I have written the following code:</p>
  
  <pre><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 &amp; "Clean" &amp; ".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
  </code></pre>
  
  <p>However I am really struggling. It seems to not work as I constantly get an error with the command (RunTimeError 438): </p>
  
  <pre><code>Selection.HomeKey Unit:=wdStory
  </code></pre>
  
  <p>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.</p>
  
  <p>I would greatly appreciate any help, I am also open to other suggestions of course. </p>
  
  <p>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.</p>
  
  <p><a href="https://i.stack.imgur.com/119Yo.jpg" rel="nofollow noreferrer"><img src="https://i.stack.imgur.com/119Yo.jpg" alt="Sample word file"></a> </p>
  
  <p>Also I have considered the following links to the topic:</p>
  
  <p><a href="https://stackoverflow.com/questions/31290923/use-vba-with-powerpoint-to-search-titles-in-a-word-doc-and-copy-text-into-anothe">Use VBA with Powerpoint to Search titles in a Word Doc and Copy Text into another Word Document</a></p>
  
  <p><a href="https://stackoverflow.com/questions/16418292/vba-open-word-from-excel">VBA: open word from excel</a></p>
  
  <p><a href="https://stackoverflow.com/questions/26763811/word-vba-select-text-between-headings">word vba: select text between headings</a></p>