我有一个 VBA 宏，可以导入保留格式的 Word 表格，但它会分割单元格的内容。
看起来断线会导致 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
我希望 Word 表格中每个单元格的内容也位于 Excel 中的一个单元格中。
它们有断裂线，因此大多数细胞都有不止一条断裂线。通常第二行以“(”开头。
由于 GDPR，我无法提供文件作为模板。
这是在我的情况下效果最好的代码，我希望它对其他人有帮助！！
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
很抱歉，由于 GDPR，我无法向您提供文件作为模板。非常感谢。
所以请尝试一下我根据你的代码用我的想象力修改的代码。
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