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
Bookmarks