none
Macro to copy line by line from word to new excel document RRS feed

  • Question

  • Hi,

    I want to loop thru each line (not paragraph) - and copy each line to new excel document what is the best way to do it?

    example:

    word document:

    Row 1 in word document: dkjfhdjfhdfhdjkfh d jdhfjk dkjhf jhdf hdjkfh djhf jkhdjkfh djhf jkdhf

    Row 2 in word document:jkhdjhf djh fdhfkdhfkhdkhfkdhfkhdfjkfhdfhdhfhdfhdkfhdhfkdh df djfh

    Row 3 in word document:djhf jkhdfh dhf hdkfh dhf hdf hdfhdhf dhfh hdfh dhfdhf hdfhdfh dhfdh

    Row 4 in word document::djhfdkfhkdfjkhdfjd fhdf djfh hdf kdjhf hd jh gfdjh kjhd djh   jdhgf jkh

    Row 5 in word document kdh

    Excel:

    each line need to put in different row in Excel

    row 1 in range("a1")

    row 2 in range("a2")

    row3 in range("a3")

    row 4 in range("a4")

    etc.

    Thanks!


    Guy Zommer

    Tuesday, September 17, 2013 4:32 AM

Answers

  • In that case I think the following should work. It accesses the words in groups of 40 characters in turn. It then moves the end of each group to the next space, then if the end was in the middle of a word, the character count will be more than 40, so the end is moved back to the previous space until the length no longer exceeds 40 characters. That block is then written to a new workbook with leading and trailing spaces removed.

    Sub Macro1()
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim oRng As Range
    Dim iCount As Long
        iCount = 0
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err Then
            Set xlApp = CreateObject("Excel.Application")
        End If
        On Error GoTo 0
        Set xlBook = xlApp.Workbooks.Add
        xlApp.Visible = True
        Set xlSheet = xlBook.Sheets(1)
        Set oRng = ActiveDocument.Range
        oRng.End = oRng.Start
        Do Until oRng.End = ActiveDocument.Range.End
            iCount = iCount + 1
            oRng.Collapse wdCollapseEnd
            oRng.MoveStartWhile Chr(32)
            oRng.End = oRng.Start
            oRng.End = oRng.End + 40
            oRng.MoveEndUntil Chr(32)
            While Len(oRng) > 40
                oRng.MoveEndUntil Chr(32), wdBackward
            Wend
            xlSheet.Range("A" & iCount) = Trim(oRng.Text)
        Loop
    End Sub

    Graham Mayor - Word MVP
    www.gmayor.com


    • Edited by Graham MayorMVP Tuesday, September 17, 2013 11:27 AM
    • Marked as answer by Guy Zommer Tuesday, September 17, 2013 7:55 PM
    Tuesday, September 17, 2013 11:25 AM

All replies

  • There are no 'lines' in a Word document. There is merely text flowed between the margins. Such text is volatile in that what is displayed on a 'line' changes with formatting. If the 'lines' are not paragraphs, what determines what constitutes the end of the 'line'.

    Graham Mayor - Word MVP
    www.gmayor.com

    Tuesday, September 17, 2013 6:47 AM
  • Thanks.

    What actually I realized that I need something else. I need to copy every 40 characters for example (inculding spaces) to different row in Excel

    For Example in word

    1fjjdjfhdj dfjh jhdf jdhf dfjh jhdf djfhjh dfjh jdfjh jjfhdj jdhfj hdjfh jdhjf1 2jdhfjh djfh jdhfjh jdhfj hdjf \dkj

    dkfjk jdf kdjfkdj2 3kdjfk jdfkdjfk jdkfjk jdkjf dkfjk jdjf dkfjk jdfjk dj kdjfk jdkfk3 4djfk djkfj kjdkfj dkjf kdjfk jdkfj

    dlfkl kldflk lkdlfk dlfkl kdlfk4 ldkfl kdlkf lkdflk ldkf ldkfl kdlk fldkfl kdlfk ldkfldkl5f kdlfkl dkflk dlfk ldkfl dfk dlk fdlf

    dlfk ldkf dlf kldkflk ldkflk5 6dlfkl kdlfkdlkf ldkfl kdlfk lkdlfk ldkf lkdlfk ldkl kdlkf ldkflk ldkfl dkfl kdlfk ldkflkdlfk dklf6

    In Excel

    Range("a1")=1fjjdjfhdj dfjh jhdf jdhf dfjh jhdf djfhjh dfjh jdfjh jjfhdj jdhfj hdjfh jdhjf1

    Range("a2")=2jdhfjh djfh jdhfjh jdhfj hdjf \dkjdkfjk jdf kdjfkdj2

    Range("a3")=3kdjfk jdfkdjfk jdkfjk jdkjf dkfjk jdjf dkfjk jdfjk dj kdjfk jdkfk3

    etc.

    There are two exceptions:

    1. Each line must include full words (Not partial words)

    2. Each line must contain all punctuation marks

    with those two exceptions in means that each row in Excel will be maximum 40 characters (beacuse we can't present partial word

    Thanks,


    Guy Zommer

    Tuesday, September 17, 2013 7:48 AM
  • In that case I think the following should work. It accesses the words in groups of 40 characters in turn. It then moves the end of each group to the next space, then if the end was in the middle of a word, the character count will be more than 40, so the end is moved back to the previous space until the length no longer exceeds 40 characters. That block is then written to a new workbook with leading and trailing spaces removed.

    Sub Macro1()
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim oRng As Range
    Dim iCount As Long
        iCount = 0
        On Error Resume Next
        Set xlApp = GetObject(, "Excel.Application")
        If Err Then
            Set xlApp = CreateObject("Excel.Application")
        End If
        On Error GoTo 0
        Set xlBook = xlApp.Workbooks.Add
        xlApp.Visible = True
        Set xlSheet = xlBook.Sheets(1)
        Set oRng = ActiveDocument.Range
        oRng.End = oRng.Start
        Do Until oRng.End = ActiveDocument.Range.End
            iCount = iCount + 1
            oRng.Collapse wdCollapseEnd
            oRng.MoveStartWhile Chr(32)
            oRng.End = oRng.Start
            oRng.End = oRng.End + 40
            oRng.MoveEndUntil Chr(32)
            While Len(oRng) > 40
                oRng.MoveEndUntil Chr(32), wdBackward
            Wend
            xlSheet.Range("A" & iCount) = Trim(oRng.Text)
        Loop
    End Sub

    Graham Mayor - Word MVP
    www.gmayor.com


    • Edited by Graham MayorMVP Tuesday, September 17, 2013 11:27 AM
    • Marked as answer by Guy Zommer Tuesday, September 17, 2013 7:55 PM
    Tuesday, September 17, 2013 11:25 AM
  • Thanks a lot !!! I will check it

    Guy Zommer

    Tuesday, September 17, 2013 7:45 PM
  • Thanks it's working. You helped me a lot!

    Have a nice day!

    Guy


    Guy Zommer

    Tuesday, September 17, 2013 7:55 PM