Sub Extract_From_Word_Document_By_Specific_Strings()
Dim wrdApp As Object
Dim wrdDoc As Object
Dim x As Variant
Dim w() As Variant
Dim v As Variant
Dim blnStart As Boolean
Dim r As Range
Dim c As Range
Dim strFile As String
Dim strContent As String
Dim ii As Integer
Dim iii As Integer
Dim cnt As Integer
Dim n As Integer
Dim i As Long
strFile = ThisWorkbook.Path & "\Naam1.docx"
On Error Resume Next
Set wrdApp = GetObject(Class:="Word.Application")
If wrdApp Is Nothing Then
Set wrdApp = CreateObject(Class:="Word.Application")
blnStart = True
End If
On Error GoTo ErrHandler
Set wrdDoc = wrdApp.Documents.Open(strFile)
strContent = wrdDoc.Content
strContent = FindInvisChar(strContent)
strContent = Replace(strContent, "||", "~")
v = Split(strContent, "~~")
Set r = Range("A2:A30").SpecialCells(xlCellTypeConstants)
For Each c In r
cnt = 0: n = 0: Erase w: x = Empty
For ii = LBound(v) To UBound(v)
If InStr(v(ii), c.Value) > 0 Then
For iii = ii To UBound(v)
If InStr(v(iii), "|") > 0 Then cnt = cnt + 1
If cnt > 1 Then Exit For
If v(iii) <> "" And InStr(v(iii), "~") > 0 And Not (InStr(v(iii), c.Value) > 0) Then
ReDim Preserve w(n)
If Left(v(iii), 2) = "~|" Then
w(n) = Trim(Mid(v(iii), 3))
Else
w(n) = Trim(v(iii))
End If
n = n + 1
End If
Next iii
End If
Next ii
If UBound(w) >= 0 Then
For iii = LBound(w) To UBound(w)
If Left(w(iii), 1) = "~" Then
ReDim Preserve w(iii - 1)
End If
Next iii
For i = LBound(w) To UBound(w)
w(i) = Split(w(i), "~")
Next i
w = Application.Index(w, 0, 0)
On Error Resume Next
x = UBound(w, 2)
On Error GoTo 0
If IsEmpty(x) Then
c.Offset(1).Resize(, UBound(w)).Value = w
Else
c.Offset(1).Resize(UBound(w, 1), UBound(w, 2)).Value = w
End If
End If
Next c
ExitHandler:
On Error Resume Next
wrdDoc.Close SaveChanges:=False
If blnStart Then wrdApp.Quit SaveChanges:=False
Exit Sub
ErrHandler:
MsgBox Err.Description, vbExclamation
Resume ExitHandler
End Sub
Function FindInvisChar(sInput As String) As String
Dim sSpecial As String
Dim sReplaced As String
Dim ln As Integer
Dim i As Long
sSpecial = "" & Chr(1) & Chr(2) & Chr(3) & Chr(4) & Chr(5) & Chr(6) & Chr(7) & Chr(8) & Chr(9) & Chr(10) & Chr(11) & Chr(12) & Chr(13) & Chr(14) & Chr(15) & Chr(16) & Chr(17) & Chr(18) & Chr(19) & Chr(20) & Chr(21) & Chr(22) & Chr(23) & Chr(24) & Chr(25) & Chr(26) & Chr(27) & Chr(28) & Chr(29) & Chr(30) & Chr(31) & Chr(32) & ChrW(&HA0)
For i = 1 To Len(sSpecial)
ln = Len(sInput)
sInput = Replace$(sInput, Mid$(sSpecial, i, 1), "|")
If ln <> Len(sInput) Then sReplaced = sReplaced & Mid$(sSpecial, i, 1)
If ln <> Len(sInput) Then sReplaced = sReplaced & IIf(Mid$(sSpecial, i, 1) = Chr(10), "<Line Feed>", Mid$(sSpecial, i, 1)) & IIf(Mid$(sSpecial, i, 1) = Chr(1), "<Start of Heading>", Mid$(sSpecial, i, 1)) & IIf(Mid$(sSpecial, i, 1) = Chr(9), "<Character Tabulation, Horizontal Tabulation>", Mid$(sSpecial, i, 1)) & IIf(Mid$(sSpecial, i, 1) = Chr(13), "<Carriage Return>", Mid$(sSpecial, i, 1)) & IIf(Mid$(sSpecial, i, 1) = Chr(28), "<File Separator>", Mid$(sSpecial, i, 1)) & IIf(Mid$(sSpecial, i, 1) = Chr(29), "<Group separator>", Mid$(sSpecial, i, 1)) & IIf(Mid$(sSpecial, i, 1) = Chr(30), "<Record Separator>", Mid$(sSpecial, i, 1)) & IIf(Mid$(sSpecial, i, 1) = Chr(31), "<Unit Separator>", Mid$(sSpecial, i, 1)) & IIf(Mid$(sSpecial, i, 1) = ChrW(&HA0), "<Non-Breaking Space>", Mid$(sSpecial, i, 1))
Next i
FindInvisChar = sInput
End Function