Copy Word file to Excel (Loop problem)

[blody]

Hello,

By getting help from the forum here, I started fixing and fiddling a pre-sent code in order to fit my needs. According to the code here;

Option Explicit
 
Public Sub FetchWordDocument()
 
 Dim wordApp As Word.Application
 Dim wordDoc As Word.Document
 Dim wordPara As Paragraph
 Dim sFileName As String
 Dim sParagraph As String
 Dim iParas As Integer
 Dim iRow As Long
 Dim iSpace As Integer
 Const iMaxLength As Integer = 0
 Dim pth As String
 Dim wkb As String
 Dim i As Integer
 Dim newBK As Workbook
 Dim initialName As String
 i = 1
 
 Do Until i = 5 ´to try out 5 documents in order to see if excel macro working properly
 pth = "c:\" ´path where the text documents are saved
 wkb = Cells(i + 1, 2) ´B coloumn is where I have the text file names
 sFileName = pth & wkb
 Set newBK = Workbooks.Add
 Set wordApp = CreateObject("Word.Application")

 
 wordApp.Visible = False
 Columns("A").ClearContents
 wordApp.Documents.Open Filename:=sFileName, _
       ConfirmConversions:=False, _
       ReadOnly:=True, _
       AddToRecentFiles:=False, _
       PasswordDocument:="", _
       PasswordTemplate:="", _
       Revert:=False, _
       WritePasswordDocument:="", _
       WritePasswordTemplate:="", _
       Format:=0
 iRow = 0
 iParas = 0
 For Each wordPara In ActiveDocument.Paragraphs
   iParas = iParas + 1
   sParagraph = wordPara.Range.Text
   If Right(sParagraph, 1) = vbCr Then
     sParagraph = Left(sParagraph, Len(sParagraph) - 1)
   End If
   newBK.Activate
   If iMaxLength > 0 Then
     Do Until Len(sParagraph) <= iMaxLength
       iSpace = InStrRev(Left(sParagraph, iMaxLength), " ")
       iRow = iRow + 1
       Cells(iRow, 1) = Left(sParagraph, iSpace)
       sParagraph = Mid(sParagraph, iSpace + 1)
     Loop
   End If
   iRow = iRow + 1
   Cells(iRow, 1) = sParagraph
 Next wordPara

Application.ScreenUpdating = False
newBK.Saveas Filename:="C:\XXX path to save the excel files" & wkb & " contract " & Format(Date, "dd-mm-yy") & ".xls"
Application.ScreenUpdating = True

 wordApp.Documents.Close
 wordApp.Quit

  
 Set wordPara = Nothing
 Set wordDoc = Nothing
 Set wordApp = Nothing
 newBK.Close
 Workbooks("avtal listing").Activate
i = i + 1
Loop
MsgBox "Done!"
End Sub

The macro should ;
*Get the name of doc file I want to open from the "B" coloumn, there are at least 160 documents,
*Open doc files one by one
*Copy the open doc file in a new excel file as each paragraf to fit one cell
*Save the excel file in the defined destination with the name of doc file and date (with addition of word "contract")
*Close the word file
*Close the new excel file
*Loop to open the next doc file and so on...
*When done with all the file in the "B" coloumn, give the message "done"

In this code, the loop only goes 5 steps in order to save time (I do trials to check if the code is working as I want it to). I am aware that normal loop should have been written in another way.

The code works but; I get the same doc file copied into all the excel files under different names. So what I figure is that actually the loop for the doc file name is not fulfilling its duty. which is why I am thinking I have made a mistake in the code.

I need help, if possible.

 

[Ruddles]

I recognise that code!

Okay, try replacing this:-

 wordApp.Documents.Open Filename:=sFileName, _
       ConfirmConversions:=False, _
       ReadOnly:=True, _
       AddToRecentFiles:=False, _
       PasswordDocument:="", _
       PasswordTemplate:="", _
       Revert:=False, _
       WritePasswordDocument:="", _
       WritePasswordTemplate:="", _
       Format:=0
 iRow = 0
 iParas = 0
 For Each wordPara In ActiveDocument.Paragraphs

with this:-

     [COLOR=red][B]Set wordDoc =[/B][/COLOR] wordApp.Documents.Open[B][COLOR=red]([/COLOR][/B]Filename:=sFileName, _
           ConfirmConversions:=False, _
           ReadOnly:=True, _
           AddToRecentFiles:=False, _
           PasswordDocument:="", _
           PasswordTemplate:="", _
           Revert:=False, _
           WritePasswordDocument:="", _
           WritePasswordTemplate:="", _
           Format:=0[COLOR=red][B])[/B][/COLOR]
     iRow = 0
     iParas = 0
     For Each wordPara In [COLOR=red][B]wordDoc.[/B][/COLOR]Paragraphs

 

[blody]

It seems working as I wish it to work,

Thank you very much

Now to fix the loop part and let it do it on its own

Once more Thank you

//Diga

 

[Ruddles]

Yes, sorry, my original code was at fault.

 

[blody]

Ruddles,

I am wondering if its possible to use this as word by word copy instead of paragraph by paragraph?

It did work wonderfully but the source files I have are way too different than each other and in a way I need to standardise them.

 

[Ruddles]

I'm not quite sure what you mean. Do you want each word on a separate row in the worksheet?

 

[blody]

Copy each word in a different cell until the sourcefile does not have any other words left on it instead of paragraphs

 

[Ruddles]

Replace this section of code:-

    If iMaxLength > 0 Then
      Do Until Len(sParagraph) <= iMaxLength
        iSpace = InStrRev(Left(sParagraph, iMaxLength), " ")
        iRow = iRow + 1
        Cells(iRow, 1) = Left(sParagraph, iSpace)
        sParagraph = Mid(sParagraph, iSpace + 1)
      Loop
    End If

with this:-

    iSpace = InStr(sParagraph, " ")
    Do Until iSpace = 0
      iRow = iRow + 1
      Cells(iRow, 1) = Left(sParagraph, iSpace - 1)
      sParagraph = Trim(Mid(sParagraph, iSpace + 1))
      iSpace = InStr(sParagraph, " ")
    Loop

It's very simplistic: it just breaks the paragraph up at each space character with no attempt to do anything more sophisticated (like dealing with punctuation).

 

[blody]

Wish it sounded as easy for me :D thank you very much