Imports Word tables preserving format, but it splits the content of cells

Question

I have a VBA macro that Imports Word tables preserving format, but it splits the content of cells. It seems that the break lines are causing the content to be split into several cells in excel. I am not very good at coding and could not find any solution. I can just ask for help from experts in this forum. Below is the macro. I would really appreciate your help. Thank you!!

Sub ImportTablesAndFormat()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdTbl As Object
    Dim wdCell As Object
    Dim wdRange As Object
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object
    Dim xlCell As Object
    Dim myPath As String
    Dim myFile As String
    Dim numRows As Long
    Dim numCols As Long
    Dim i As Long
    Dim j As Long

    ' Prompt user to select folder with Word files
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder with Word Files"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        myPath = .SelectedItems(1) & "\"
    End With
 
    ' Create new Excel workbook
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlCell = xlBook.Sheets(1).Cells(1, 1)
 
    ' Loop through each Word file in folder
    myFile = Dir(myPath & "*.docx")
    Do While myFile <> ""
        ' Open Word document
        Set wdApp = CreateObject("Word.Application")
        Set wdDoc = wdApp.Documents.Open(myPath & myFile)
        wdApp.Visible = False
 
        ' Loop through each table in Word document
        For Each wdTbl In wdDoc.Tables
            ' Get dimensions of table
            numRows = wdTbl.Rows.Count
            numCols = wdTbl.Columns.Count
 
            ' Add new sheet to Excel workbook
            Set xlSheet = xlBook.Sheets.Add(After:=xlBook.Sheets(xlBook.Sheets.Count))
            xlSheet.Name = myFile & "Table" & xlSheet.Index
 
            ' Copy table to Word range
            Set wdRange = wdTbl.Range
            wdRange.Copy
 
            ' Paste table to Excel range
            xlSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False

            ' Clear clipboard
            Application.CutCopyMode = False
 
            ' Adjust cell dimensions to match Word table
            For i = 1 To numRows
                For j = 1 To numCols
                    Set wdCell = wdTbl.Cell(i, j)
                    Set xlCell = xlSheet.Cells(i, j)
                   
                    ' Replace line breaks with a space
                    Dim cellText As String
                    cellText = Replace(wdCell.Range.Text, Chr(13), " ")
                    cellText = Replace(cellText, Chr(11), " ") ' Optional: Replace manual line breaks as well
                    xlCell.Value = cellText
                    xlCell.WrapText = wdCell.Range.ParagraphFormat.WordWrap
                    xlCell.Font.Bold = wdCell.Range.Font.Bold
                    xlCell.Font.Italic = wdCell.Range.Font.Italic
                    xlCell.Font.Color = wdCell.Range.Font.Color
                    xlCell.Interior.Color = wdCell.Range.Shading.BackgroundPatternColor
                    xlCell.Borders(xlEdgeLeft).LineStyle = wdCell.Borders(-1).LineStyle
                    xlCell.Borders(xlEdgeLeft).Weight = xlMedium
                    xlCell.EntireRow.AutoFit
                Next j
            Next i

            ' Clear contents of Word range
            wdRange.Delete
 
        Next wdTbl
 
        ' Close Word document
        wdDoc.Close SaveChanges:=False
        Set wdDoc = Nothing
 
        ' Move to the next Word file in the folder
        myFile = Dir
    Loop
 
    ' Set the column widths
    For Each xlSheet In xlBook.Sheets
        xlSheet.Columns(1).ColumnWidth = 82
        xlSheet.Columns(2).ColumnWidth = 32
    Next xlSheet
 
    ' Save and close the Excel workbook
    xlBook.SaveAs Filename:=myPath & "Tables.xlsx", FileFormat:=51
    xlBook.Close SaveChanges:=True
    xlApp.Quit
 
    ' Clean up objects
    Set xlCell = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
 
    ' Display completion message
    MsgBox "All tables from Word files in " & myPath & " have been imported into the Excel workbook " & myPath & "Tables.xlsx.", vbInformation, "Tables Converted"
End Sub

Tried to modify the loop in several ways I found online, but nothing would work. I lack the knowledge to try anything deeper I guess. I just want the content of every cell in the tables in word to be in one cell also in excel. a copy and paste really. They have break lines, so most of cells have more than one line. Usually the second line start with a "(", if that helps. The format is being copied ok. I am sorry I cannot provide you with a file as a template due to GDPR. Thanks a lot.

Answer 1

This is the code that worked the best in my case I hope it helps someone else!!

Sub ImportWordTables()

    ' Application variables
    Dim wordApp As Object
    Dim wordDoc As Object
    Dim table As Object
    
    ' Document variables
    Dim wordDocsFolder As String
    Dim docPath As String
    
    ' Excel variables
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim nextRow As Long
    Dim sheetName As String
    
    'Optimize Performance
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    ' Set up applications
    Set wordApp = CreateObject("Word.Application")
    wordApp.Visible = False
    
    ' Setup workbook
    Set wb = ThisWorkbook
    
    ' Prompt user for folder containing Word docs
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            wordDocsFolder = .SelectedItems(1)
        End If
    End With
    
    ' Get first Word doc
    docPath = Dir(wordDocsFolder & "\*.docx", vbNormal)
    
    ' Process each Word doc
    Do While docPath <> ""
        ' Open Word doc
        Set wordDoc = wordApp.Documents.Open(wordDocsFolder & "\" & docPath)
        
        ' Create a new sheet for the Word doc
        sheetName = "Sheet" & Format(Now, "yyyymmddhhmmss")
        Set ws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
        ws.Name = sheetName
        
        ' Copy each table and paste into Excel
        For Each table In wordDoc.Tables
            ' Replace ^p by " ||" in Word
            table.Range.Find.Execute FindText:="^p", ReplaceWith:=" ||", Replace:=wdReplaceAll

            ' Copy table content
            table.Range.Copy
                
            ' Find next empty row in Excel
            nextRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
                
            ' Paste table with formatting
            ws.Cells(nextRow, 1).Select
            ws.Paste
                
            ' Avoid clipboard message when closing Word later
            Application.CutCopyMode = False

            ' Loop through rows, not cells
            Dim i As Long
            For i = 1 To ws.UsedRange.Rows.Count
                Dim cell As Range
                Set cell = ws.Cells(i, "B")
                ' If B and C are merged
                If cell.MergeCells And cell.MergeArea.Columns.Count > 1 Then
                    ' Store merge info, then unmerge
                    Dim mergeRowCount As Long
                    mergeRowCount = cell.MergeArea.Rows.Count
                    cell.MergeArea.UnMerge
                    ' Clear column C
                    cell.Offset(0, 1).Resize(mergeRowCount, 1).ClearContents
                    ' Re-merge cells vertically
                    cell.Resize(mergeRowCount, 1).Merge
                End If
                ' Repeat for D and E
                Set cell = ws.Cells(i, "D")
                If cell.MergeCells And cell.MergeArea.Columns.Count > 1 Then
                    mergeRowCount = cell.MergeArea.Rows.Count
                    cell.MergeArea.UnMerge
                    cell.Offset(0, 1).Resize(mergeRowCount, 1).ClearContents
                    cell.Resize(mergeRowCount, 1).Merge
                End If
            Next i
        Next table




        
        ' Finalize Excel sheet
        ws.Cells.Replace What:=" ||", Replacement:=" ", LookAt:=xlPart
        ws.Cells.Replace What:="  ", Replacement:=" ", LookAt:=xlPart
        ws.Columns(1).ColumnWidth = 70
        If ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column > 1 Then
            ws.Columns(2).Resize(, ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column - 1).ColumnWidth = 30
        End If
        
        ' Wrap text
        ws.Cells.WrapText = True
        
        ' Close Word doc without saving
        wordDoc.Close SaveChanges:=False
        
        ' Get next Word doc
        docPath = Dir()
    Loop
    
    ' Clean up
    wordApp.Quit
    Set wordApp = Nothing
    
    'Restore Defaults
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Answer 2

I am sorry I cannot provide you with a file as a template due to GDPR. Thanks a lot.

So plz try the code which I've modified with my imagination according to your code.

Sub ImportTablesAndFormat()
    Dim wdApp As Object 'Word.Application
    Dim wdDoc As Object
    Dim wdTbl As Object 'Word.Table
    Dim wdCell As Object
    Dim wdRange As Object
    Dim xlApp As Object
    Dim xlBook As Object
    Dim xlSheet As Object 'Excel.Worksheet
    Dim xlCell As Object
    Dim myPath As String
    Dim myFile As String
    Dim numRows As Long
    Dim numCols As Long
    Dim i As Long
    Dim j As Long

    ' Prompt user to select folder with Word files
    With Application.FileDialog(msoFileDialogFolderPicker)
        .title = "Select Folder with Word Files"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        myPath = .SelectedItems(1) & "\"
    End With
 
    ' Create new Excel workbook
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    Set xlCell = xlBook.Sheets(1).Cells(1, 1)
 
    ' Loop through each Word file in folder
    myFile = Dir(myPath & "*.docx")
    
    Rem just initiate Word app once
    Set wdApp = CreateObject("Word.Application")
    wdApp.Visible = False
    
    Do While myFile <> ""
        ' Open Word document
'        Set wdApp = CreateObject("Word.Application")
        Set wdDoc = wdApp.Documents.Open(myPath & myFile)
        'wdApp.Visible = False
 
        ' Loop through each table in Word document
        For Each wdTbl In wdDoc.Tables
            ' Get dimensions of table
            numRows = wdTbl.Rows.Count
            numCols = wdTbl.Columns.Count
 
            ' Add new sheet to Excel workbook
            Set xlSheet = xlBook.Sheets.Add(After:=xlBook.Sheets(xlBook.Sheets.Count))
            xlSheet.Name = myFile & "Table" & xlSheet.Index
 
            
            '' Replace line breaks with a space
            Rem Replace line breaks with chr(10)s to retain the format like Word
            Dim cellText As String
            For Each wdCell In wdTbl.Range.Cells
                cellText = Replace(wdCell.Range.Text, Chr(13), ", ,") ' Line break mark is chr(10) in Excel, however in Word it Seems to be replace with chr(13)
                cellText = Replace(cellText, Chr(11), ", ,") ' Optional: Replace manual line breaks as well
                
'                cellText = Replace(wdCell.Range.Text, Chr(13), Chr(10)) '" ")' Line break mark is chr(10) in Excel, however in Word it Seems to be replace with chr(13)
'                cellText = Replace(cellText, Chr(11), Chr(10)) '" ") ' Optional: Replace manual line breaks as well
            Next wdCell
            
            
            ' Copy table to Word range
            Set wdRange = wdTbl.Range
            wdRange.Copy
 
            ' Paste table to Excel range
            xlSheet.PasteSpecial Format:="HTML", Link:=False, DisplayAsIcon:=False

            ' Clear clipboard
            Application.CutCopyMode = False
 
            ' Adjust cell dimensions to match Word table
            For i = 1 To numRows
                For j = 1 To numCols
                    Set wdCell = wdTbl.cell(i, j)
                    Set xlCell = xlSheet.Cells(i, j)
                    
                    cellText = wdCell.Range.Text
                    cellText = VBA.Left(cellText, VBA.Len(cellText) - 2) 'there will be Chr(13)& chr(7) in the end of each cell
                    cellText = VBA.Replace(cellText, ", ,", Chr(10)) 'restore the Word line break format
                    
'                    ' Replace line breaks with a space
'                    Dim cellText As String
'                    cellText = Replace(wdCell.Range.Text, Chr(13), " ")
'                    cellText = Replace(cellText, Chr(11), " ") ' Optional: Replace manual line breaks as well
                    xlCell.Value = cellText
                    xlCell.WrapText = wdCell.Range.ParagraphFormat.WordWrap
                    xlCell.Font.Bold = wdCell.Range.Font.Bold
                    xlCell.Font.Italic = wdCell.Range.Font.Italic
                    xlCell.Font.color = wdCell.Range.Font.color
                    xlCell.Interior.color = wdCell.Range.Shading.BackgroundPatternColor
                    xlCell.Borders(xlEdgeLeft).LineStyle = wdCell.Borders(-1).LineStyle
                    xlCell.Borders(xlEdgeLeft).Weight = xlMedium
                    xlCell.EntireRow.AutoFit
                Next j
            Next i

            ' Clear contents of Word range
            'wdRange.Delete
            Rem  why do you do this? you do not save the doc `wdDoc.Close SaveChanges:=False` and next to the next table
            Rem so This line is unnecessary.
 
        Next wdTbl
 
        ' Close Word document
        wdDoc.Close SaveChanges:=False
        
        Rem Run this at the end to release the memory.
        'Set wdDoc = Nothing
 
        ' Move to the next Word file in the folder
        myFile = Dir
    Loop
 
    Rem close word app and release the memory.
    wdApp.Quit
    Set wdDoc = Nothing: Set wdApp = Nothing
     
    ' Set the column widths
    For Each xlSheet In xlBook.Sheets
        xlSheet.Columns(1).ColumnWidth = 82
        xlSheet.Columns(2).ColumnWidth = 32
    Next xlSheet
 
    ' Save and close the Excel workbook
    xlBook.SaveAs FileNAme:=myPath & "Tables.xlsx", FileFormat:=51
    xlBook.Close SaveChanges:=True
    xlApp.Quit
 
    ' Clean up objects
    Set xlCell = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
 
    ' Display completion message
    MsgBox "All tables from Word files in " & myPath & " have been imported into the Excel workbook " & myPath & "Tables.xlsx.", vbInformation, "Tables Converted"
End Sub

• Do you have merged cells in Word's tables?
• Why you do xlSheet.PasteSpecial before ' Replace line breaks with a space of Adjust cell dimensions to match Word table? Logically should be reversed.