Copying multiple line text Cell from Word Table to Excel Cell

Question

I figured out how to copy the cell directly from a Word table to a Excel Cell.

The cell in Word may contain multiple lines separated by pressing enter. So you have one line, press enter, next line and so on.

I want to copy this exactly as it looks into Excel. When I copy it, the entire string is one line in the Excel cell.

First capture is from Word and the next is an Excel cell.

Below is the code for copying into the first column. The rest are not needed. I am working in the Outlook so that is why I have the Excel library and the Word library being used. The code will scrape emails with Word documents.

With wrd.Tables(1)
    xlSht.Cells(j, 1).Value = WorksheetFunction.Clean(.Cell(2, 2).Range.Text)
    xlSht.Cells(j, 2).Value = WorksheetFunction.Clean(.Cell(3, 2).Range.Text)
    xlSht.Cells(j, 4).Value = Atmt.FileName
End With

I tried splitting the Excel cell with some logic but it is hard to detect where the enter needs to happen.
Note: The "and" will not be used in all the text. It varies so I can't use that to split the Excel cell.

Answer 1

To start, make sure that the "Wrap Text" option is enabled on the cell you are writing to or it won't display line breaks properly even if they exist in the text.

Now that this is cleared out of the way, there are 2 different reasons why your code doesn't preserve the line breaks from the Word table. The first is that you are using the CLEAN function. The second is that there's a problem with how data is passed from the Word table using VBA (some information is lost). Luckily, there are ways to solve those problems.

Avoid using the CLEAN function

When you use the CLEAN function, you remove all the non-printable characters from a string of text. The problem is that the "formatting" that you see in the Word table is actually caused by the presence of 2 non-printable characters (or at least one of them). Those characters are the carriage return (CR) and the line feed (LF) characters. By using the CLEAN function you are asking to remove those characters which removes the information indicating a line break.

So I tried to do the same as you without the CLEAN function and made a Word table

then I used the following code to write the content of the first cell to Excel.

Sub ReadFromWordTable()

Dim WordApp As Word.Application
Set WordApp = GetObject(, "Word.Application")

Dim WordDoc As Word.Document
Set WordDoc = WordApp.ActiveDocument

Dim xlSht As Worksheet
Set xlSht = ActiveSheet

Dim TempString As String

With WordDoc.Tables(1)
    TempString = .Range.Text
End With

xlSht.Cells(1, 1).Value2 = TempString

'StringDrillDown TempString

End Sub

and saw that the line break does not appear (we'll come back to this later) and that there is some garbage characters at the end of my cell.

Now I see why you used the CLEAN function : to make those garbage characters go away! If only there was an out-of-the-box VBA function to remove those non-printable characters without removing CR and LF from the string!

Since there isn't any and that they only appear at the end, I would suggest to simply clean TempString using the following code which will remove all the non-printable characters starting from the right and stop as soon as it encounters a printable character.

    Dim i As Long, NbOfCharacter As Long
    NbOfCharacter = Len(TempString)
    
    For i = Len(TempString) To 1 Step -1
        If Asc(Mid(TempString, i, 1)) < 32 Then
            NbOfCharacter = NbOfCharacter - 1
        Else
            Exit For
        End If
    Next
    
    TempString = Left(TempString, NbOfCharacter)

Note here that I'm using the Asc function. It returns the Extended ASCII (aka. ANSI) character code (a number from 1 to 255) that uniquely identifies a character. In our case, all non-printable characters return a value below 32 so we can easily filter them out.

Make sure the line feed character is present in the string you write to the cell

As you saw when we used the value of .Range.Text directly, the line break didn't get passed through correctly. To understand the problem, we might want to drill down on the different characters that make up our TempString variable. For that you could use a procedure like this:

Sub StringDrillDown(str As String)

    Dim ws As Worksheet
    With ActiveWorkbook
        Set ws = .Sheets.Add(AFTER:=.Sheets(.Sheets.Count))
    End With

    ws.Range("A1") = "Character"
    ws.Range("B1") = "Ascii Code"
    Dim i As Long
    For i = 1 To Len(str)
        ws.Cells(i + 1, 1).Value2 = Mid$(str, i, 1)
        ws.Cells(i + 1, 2).Value2 = Asc(Mid$(str, i, 1))
    Next i

End Sub

Giving us this:

What we notice is that the only character we have between "and" and "some" is the character number 13 which corresponds to CR (this seems to be a quirk of how string data is transferred between Word and Excel). So, we are missing the LF requiered to make it clear to Excel that we want a line break between those 2 words.

To solve this issue, we could use the following :

    With WordDoc.Tables(1)
        TempString = Replace(.Cell(1, 1).Range.Text, Chr(13), Chr(13) & Chr(10))
    End With

This code will replace all lonely CR by a CRLF (note that the character code for LF is 10).

A cautionary note: If there were already CRLF characters in the string, the line of code above would double them but that's not the case here.

Finally, our initial code example would now be the following:

Sub ReadFromWordTable()

    Dim WordApp As Word.Application
    Set WordApp = GetObject(, "Word.Application")
    
    Dim WordDoc As Word.Document
    Set WordDoc = WordApp.ActiveDocument
    
    Dim xlSht As Worksheet
    Set xlSht = ActiveSheet
    
    Dim TempString As String
    
    With WordDoc.Tables(1)
        TempString = Replace(.Cell(1, 1).Range.Text, Chr(13), Chr(13) & Chr(10))
    End With
    
    Dim i As Long, NbOfCharacter As Long
    NbOfCharacter = Len(TempString)
    
    For i = Len(TempString) To 1 Step -1
        If Asc(Mid(TempString, i, 1)) < 32 Then
            NbOfCharacter = NbOfCharacter - 1
        Else
            Exit For
        End If
    Next
    
    TempString = Left(TempString, NbOfCharacter)
    
    xlSht.Cells(1, 1).Value2 = TempString
    
    'StringDrillDown TempString

End Sub