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
Preview:
downloadDownload PNG
downloadDownload JPEG
downloadDownload SVG
Tip: You can change the style, width & colours of the snippet with the inspect tool before clicking Download!
Click to optimize width for Twitter