Browse Word Document data into excel sheet

[Parth007]

Hi Team,

1) I need to Browse the Folder to select a particular file (user Choice)
once selected it should copy all data from word file & paste it in Excel sheet("A1")

2) after which it sorts
3) Plot formula to track if the Column D have value greater than 0

Column should result if any cell in column d have value greater than 0


I have some code..I am able to sort it via code..

But cant get through folder select & paste word data in excel.. & plotting formula..
I tried seqarching for code.. but couldnt get through right one
Please assist

Thank You



Below is the code for folder select & select a file.. but how to modify it so that word data gets pasted in excel A1

Sub GetFormData()
     'Note: this code requires a reference to the Word object model
    Application.ScreenUpdating = False
    Dim wdApp As New Word.Application
    Dim wdDoc As Word.Document
    Dim CCtrl As Word.ContentControl
    Dim strFolder As String, strFile As String
    Dim WkSht As Worksheet, i As Long, j As Long
    strFolder = GetFolder
    If strFolder = "" Then Exit Sub
    Set WkSht = ActiveSheet
    i = WkSht.Cells(WkSht.Rows.Count, 1).End(xlUp).Row
    strFile = Dir(strFolder & "\*.doc", vbNormal)
'    While strFile <> ""
'        i = i + 1
'        Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
'        With wdDoc
'            j = 0
'            For Each CCtrl In .ContentControls
'                j = j + 1
'                WkSht.Cells(i, j) = CCtrl.Range.Text
'            Next
'        End With
'        wdDoc.Close SaveChanges:=False
'        strFile = Dir()
'    Wend
    wdApp.Quit
    Set wdDoc = Nothing: Set wdApp = Nothing: Set WkSht = 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

[Parth007]

I got this code which copies the dsata from word to excel.. but it prompts that Doc file is in use..
Unless i click any radio button it wont move ahead.. how do i ignore this automatically..

Sub CopyWordTable()
'requires a reference to Word Object Library (Tools - References)
    Dim appWord As Word.Application
    Dim docWord As Word.Document
    Dim strDoc As String
    Dim tableWord As Word.Table
    
    'Word document and this Excel workbook are in the same folder
    'Table.doc contains a table formatted with various colours, fonts, borders and bullets
    
    strDoc = ThisWorkbook.Path & "\" & "LINEN.doc"
    
    Set appWord = New Word.Application
    appWord.Visible = True
    Application.DisplayAlerts = False

    Set docWord = appWord.Documents.Open(strDoc)
    Application.DisplayAlerts = False

    'copy first table in document to clipboard
    Word.Selection.WholeStory
    Word.Selection.Copy

    
    'paste table on worksheet
    ActiveSheet.Paste Destination:=ActiveSheet.Range("A1")
    
    docWord.Close
    appWord.Quit
    
    Set tableWord = Nothing
    Set docWord = Nothing
    Set appWord = Nothing
    
End Sub

[Parth007]

Got it the below code copies all word contents in each specific sheet.

Sub GetThem()
    Dim mpWord As Object
    Dim mpDoc As Object
    Dim mpNext As Long
    Dim mpStart As Boolean
    Dim mpData As String
    Dim mpDirectory As String
    Dim mpFilename As String
     
    With Application
         
        With .FileDialog(msoFileDialogFolderPicker)
             
            .AllowMultiSelect = False
            If .Show = -1 Then
                 
                mpDirectory = .SelectedItems(1)
                 
                Set mpWord = CreateObject("Word.Application")
                mpWord.Visible = True
                 
                mpFilename = Dir(mpDirectory & Application.PathSeparator & "*.doc")
                Do
                     
                    Set mpDoc = mpWord.Documents.Open(mpDirectory & Application.PathSeparator & mpFilename)
                    mpData = ""
                     
                    With mpDoc
                         
                        mpNext = mpNext + 1
                        Worksheets.Add after:=Worksheets(Worksheets.Count)
                        ActiveSheet.Name = "File " & mpNext
                        .Range(.Content.Start, .Content.End).Copy
                        ActiveSheet.Paste
                         
                        .Close
                    End With
                     
                    mpFilename = Dir
                Loop Until mpFilename = ""
            End If
        End With
    End With
     
    mpWord.Quit
    Set mpWord = Nothing
End Sub