Consulting

Results 1 to 7 of 7

Thread: Extract test from word into excel

  1. #1
    VBAX Regular
    Joined
    Mar 2018
    Posts
    9
    Location

    Extract test from word into excel

    Hello!

    First of all i'm a noob when it comes to VBA but what i'm looking for is a way to extract text from a word file into excel table.
    The words in the word document contents 4 names that are the same but underneath that text everything else is different in number of text:
    example:

    Text1
    first
    second
    thirt
    Text2
    appel
    lemon
    Test3
    pikkel
    Test4
    saus

    How can i export that text to excel.
    PLEASE help

  2. #2
    Hello
    I think it is better to upload sample of your file and put the expected output so as to find better help

  3. #3
    VBAX Regular
    Joined
    Mar 2018
    Posts
    9
    Location
    Yes your right.
    Here is an example of how it should look like
    Attached Files Attached Files

  4. #4
    Try this code
    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

  5. #5
    VBAX Regular
    Joined
    Mar 2018
    Posts
    9
    Location
    YES that works!!
    but i have one small question is it possible to select a file from a folder?

  6. #6
    Replace this line
    strFile = ThisWorkbook.Path & "\Naam1.docx"
    with these lines
        With Application.FileDialog(msoFileDialogFilePicker)
            .AllowMultiSelect = False
            If .Show = -1 Then strFile = .SelectedItems(1) Else Exit Sub
        End With

  7. #7
    VBAX Regular
    Joined
    Mar 2018
    Posts
    9
    Location
    Thank you Thank you it WORKSS!

Tags for this Thread

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •