I have a VBA macro that imports Word tables preserving format, but it splits the content of cells.
It seems break lines cause the content to be split into several cells in Excel.
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
I want the content of each cell in the tables in Word to be in one cell also in Excel.
They have break lines, so most of cells have more than one line. Usually the second line start with a "(".
I cannot provide a file as a template due to GDPR.
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