Excel Macro for Find/Copy Keywords from Word Files to Excel

[akalyoncu]

Hey folks,
I'm rookie on excel/Word vb and trying to learn everyday. Also new in the forum.
I'm an engineer phd student and I have a lot of Word documents about some buildings(thesis like 2400 building) and I need to get length/width and height values of those buildings to excel .

I'm trying to write an excel macro which find a keyword in Word documents and copy to excel sheet.

Below is a list of what I want the macro to do, along with what I have so far (sorry that it's not much!).
1. Choose the folder which Word documents are in.
2. Open the first Word document and Find a keyword ("length or something else") in the Word.
3. Copy the keyword with five before and five after letter (exmple: keyword is "length : " it will returns with "sa - length: 5.0".
4. Paste it to excel sheet which macro is running.
5. Do the same process for another Word document in the folder.

Code, both what I wrote and strings I tried to piece together from a replace macro I found online for excel vb.
If I can run it for one Word document I can multiply it for the every document in the folder.

Option Explicit
Sub ImportWord()
Dim wdDoc As Object
Dim wdFileName As Variant
Dim SearchTerm As String, WordsAfter As Long, WordsBefore As Long, i As Long
Dim Rng As Range, Doc As Document, RngOut As Range
On Error Resume Next
ActiveSheet.Range("A:AZ").ClearContents
wdFileName = Application.GetOpenFilename("Word files (*.docx),*.docx", , _
"Browse for file containing table to be imported")
If wdFileName = False Then Exit Sub
Set wdDoc = GetObject(wdFileName)
With wdDoc
SearchTerm = "WIDTH                :"
SearchTerm = LCase(Trim(SearchTerm))
If Len(SearchTerm) = 0 Then Exit Sub
WordsBefore = 0
WordsAfter = 3
With ActiveDocument.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = SearchTerm
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = False
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .Execute
  End With
If .Find.Found Then
    Set Doc = Documents.Add(Visible:=True)
    Do While .Find.Found
      Set Rng = .Duplicate
      With Rng
        .MoveStart wdWord, -WordsBefore
        .MoveEnd wdWord, WordsAfter + 2
        .Select
          .Copy
          With Doc
            .Range.InsertAfter vbCr
            Set RngOut = .Characters.Last
            RngOut.Paste
          End With
        End If
      End With
      .Collapse wdCollapseEnd
      .Find.Execute
    Loop
    Doc.Activate
    ActiveWindow.Visible = True
  End If
End With
End With
End Sub