Macro to extract text from Word doc | Chandoo.org Excel Forums - Become Awesome in Excel
Mon May 06 2024 21:04:29 GMT+0000 (Coordinated Universal Time)
Saved by
@acassell
Sub GetWordData()
'Note: this code requires a reference to the Word object model. See under the VBE's Tools|References.
Application.ScreenUpdating = False
Dim wdApp As New Word.Application, wdDoc As Word.Document, c As Long, r As Long
Dim strFolder As String, strFile As String, WkBk As Workbook, WkSht As Worksheet
strFolder = GetFolder: If strFolder = "" Then GoTo ErrExit
Set WkBk = ActiveWorkbook
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
Set WkSht = WkBk.Sheets.Add: r = 4
WkSht.Name = Split(strFile, ".doc")(0)
WkBk.Sheets(1).Range.Copy
WkSht.Paste
WkSht.Range("A2").Value = WkSht.Name
With wdDoc
With .Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
'Find blocks of text of interest
.Text = "Uid:*Units:*^13"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.MatchWildcards = True
.Execute
End With
Do While .Find.Found
r = r + 1
'Parse & write the text to Excel
For c = 1 To 4
WkSht.Cells(r, c).Value = Trim(Split(Split(.Text, vbCr)(c - 1), ":")(1))
Next
.Collapse wdCollapseEnd
.Find.Execute
Loop
End With
.Close SaveChanges:=False
End With
strFile = Dir()
Wend
ErrExit:
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = Nothing: Set WkBk = Nothing
Application.ScreenUpdating = True
End Sub
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
content_copyCOPY
https://chandoo.org/forum/threads/macro-to-extract-text-from-word-doc.43933/
Comments