VBA宏导入Word表格至Excel时单元格内容拆分问题求助

你的VBA宏在导入Word表格时，因单元格内换行符导致内容被拆分为多个Excel单元格，核心原因是使用了HTML格式粘贴——该方式会将Word内的换行解析为单元格分隔；同时原代码中粘贴后再覆盖单元格值的逻辑，可能因粘贴后的表格结构变化导致行列不匹配。

解决方案 #

移除HTML粘贴步骤，直接循环读取每个Word单元格的内容并写入Excel对应单元格，同时正确处理Word单元格内的特殊字符（换行符、单元格结束符）。

修改后的完整代码 #

Sub ImportTablesAndFormat()
    Dim wdApp As Object
    Dim wdDoc As Object
    Dim wdTbl As Object
    Dim wdCell 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

    ' 提示用户选择包含Word文件的文件夹
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择Word文件所在文件夹"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub
        myPath = .SelectedItems(1) & "\"
    End With
 
    ' 创建新Excel工作簿
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = xlApp.Workbooks.Add
    xlApp.Visible = True ' 可选：让Excel可见，方便调试
 
    ' 遍历文件夹中的每个Word文件
    myFile = Dir(myPath & "*.docx")
    Do While myFile <> ""
        ' 打开Word文档
        Set wdApp = CreateObject("Word.Application")
        Set wdDoc = wdApp.Documents.Open(myPath & myFile)
        wdApp.Visible = False
 
        ' 遍历Word文档中的每个表格
        For Each wdTbl In wdDoc.Tables
            ' 获取表格维度
            numRows = wdTbl.Rows.Count
            numCols = wdTbl.Columns.Count
 
            ' 添加新工作表到Excel工作簿
            Set xlSheet = xlBook.Sheets.Add(After:=xlBook.Sheets(xlBook.Sheets.Count))
            xlSheet.Name = Left(myFile, Len(myFile) - 5) & "Table" & xlSheet.Index ' 去掉.docx后缀
 
            ' 直接遍历Word表格的每个单元格，写入Excel并设置格式
            For i = 1 To numRows
                For j = 1 To numCols
                    Set wdCell = wdTbl.Cell(i, j)
                    Set xlCell = xlSheet.Cells(i, j)
                   
                    ' 处理Word单元格文本：移除单元格结束符Chr(7)，替换换行符
                    Dim cellText As String
                    cellText = wdCell.Range.Text
                    cellText = Left(cellText, Len(cellText) - 2) ' 移除末尾的Chr(13)+Chr(7)
                    cellText = Replace(cellText, Chr(11), " ") ' 替换手动换行符为空格（可改为Chr(10)保留Excel内换行）
                    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(wdBorderLeft).LineStyle
                    xlCell.Borders(xlEdgeLeft).Weight = xlMedium
                Next j
                ' 自动调整行高
                xlSheet.Rows(i).AutoFit
            Next i
 
        Next wdTbl
 
        ' 关闭Word文档
        wdDoc.Close SaveChanges:=False
        wdApp.Quit
        Set wdDoc = Nothing
        Set wdApp = Nothing
 
        ' 下一个Word文件
        myFile = Dir
    Loop
 
    ' 设置列宽
    For Each xlSheet In xlBook.Sheets
        xlSheet.Columns(1).ColumnWidth = 82
        xlSheet.Columns(2).ColumnWidth = 32
    Next xlSheet
 
    ' 保存并关闭Excel工作簿
    xlBook.SaveAs Filename:=myPath & "Tables.xlsx", FileFormat:=51
    xlBook.Close SaveChanges:=True
    xlApp.Quit
 
    ' 清理对象
    Set xlCell = Nothing
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
 
    ' 提示完成
    MsgBox "所有Word文件中的表格已导入到 " & myPath & "Tables.xlsx", vbInformation, "转换完成"
End Sub

关键修改说明 #

• 移除HTML粘贴步骤：删除了wdRange.Copy和xlSheet.PasteSpecial代码，彻底避免HTML格式解析导致的单元格拆分。
• 修正文本处理逻辑：Word单元格文本末尾默认带有Chr(13)+Chr(7)，通过Left(cellText, Len(cellText)-2)移除该字符；若要保留Excel单元格内的换行，可将" "替换为Chr(10)。
• 优化工作表命名：去掉文件名中的.docx后缀，避免工作表名称包含无效字符。
• 修正边框引用：将wdCell.Borders(-1)改为wdCell.Borders(wdBorderLeft)，避免魔法数字，提升代码可读性。
• 提升执行效率：将行高调整移至外层循环，减少重复操作。

内容的提问来源于stack exchange，提问作者Yahoo