Hi,
I have Multiple word files each with different name but in same folder.
Word file is in table format.
Need to collect information from the above files and arrange them in a single row in excel file. Each word file data in separate row.
I am attaching one word file and also Excel file explaining the way data is required.
Thanks
Any suggestion on this query
Hi Akhus. Seems like you're not having much luck with this one. The likely reason is that the Word document(s) are poorly formatted for data retrieval. This will get U started. You will need to change the folder path to suit. Expand the "SearchWord" array to include all of the search items in the same order of your Sample wb headers.... note that the SearchWord items are case sensitive and must be what is in the document NOT what U have for headers in your Sample wb. Good luck. Dave
Sub test()
Dim WrdApp As Object, Cnt As Integer, FileStr As String, FlCnt As Integer
Dim WrdDoc As Object, TblCell As Variant, SearchWord() As Variant
Dim FSO As Object, FolDir As Object, FileNm As Object, ColCnt As Integer
'*** SearchWord is case sensitive and must be the same as the Word doc
SearchWord = Array("Name", "Husband's name", "Maternal UHID", "Age")
'start Word
On Error Resume Next
Set WrdApp = GetObject(, "Word.Application")
If Err.Number <> 0 Then
On Error GoTo ErFix
Set WrdApp = CreateObject("Word.Application")
End If
WrdApp.Visible = False
FlCnt = 1
Set FSO = CreateObject("scripting.filesystemobject")
'***change directory to suit
Set FolDir = FSO.GetFolder("D:\testfolder2")
'loop files
For Each FileNm In FolDir.Files
If FileNm.Name Like "*" & ".docx" Then
FileStr = CStr(FileNm)
Set WrdDoc = WrdApp.Documents.Open(FileStr)
FlCnt = FlCnt + 1
'admission
Sheets("sheet1").Range("A" & FlCnt) = Right(Left(WrdApp.ActiveDocument.Paragraphs(3), 29), 10)
'discharge
Sheets("sheet1").Range("B" & FlCnt) = Right(WrdApp.ActiveDocument.Paragraphs(3), 12)
'loop through table cells
ColCnt = 2
For Cnt = LBound(SearchWord) To UBound(SearchWord)
For Each TblCell In WrdApp.ActiveDocument.Tables(1).Range.Cells
If InStr(TblCell.Range, SearchWord(Cnt)) Then
ColCnt = ColCnt + 1
Sheets("sheet1").Cells(FlCnt, ColCnt) = WrdApp.ActiveDocument.Tables(1).Cell(TblCell.RowIndex, TblCell.ColumnIndex)
'remove pilcrow
Sheets("sheet1").Cells(FlCnt, ColCnt) = Application.WorksheetFunction.Clean(Sheets("sheet1").Cells(FlCnt, ColCnt))
'remove searchword plus 2 (:_)
Sheets("sheet1").Cells(FlCnt, ColCnt) = Right(Sheets("sheet1").Cells(FlCnt, ColCnt), _
Len(Sheets("sheet1").Cells(FlCnt, ColCnt)) - (Len(SearchWord(Cnt)) + 2))
Exit For
End If
Next TblCell
Next Cnt
'close and save doc
WrdApp.ActiveDocument.Close savechanges:=False
Set WrdDoc = Nothing
End If
Next FileNm
Set FolDir = Nothing
Set FSO = Nothing
WrdApp.Quit
Set WrdApp = Nothing
MsgBox "Finished"
Exit Sub
ErFix:
On Error GoTo 0
MsgBox "error"
Set FolDir = Nothing
Set FSO = Nothing
Set WrdDoc = Nothing
WrdApp.Quit
Set WrdApp = Nothing
End SubDon’t have an account yet? Register yourself now and be a part of our community!