Excel VBA复制Word表格为图片粘贴至Excel仅显示部分内容的解决方法

原代码出现表格图片仅显示首部内容，是两个问题叠加导致：

1. 直接调用tableItem.Range.Copy时，Word不会强制加载跨页/长表格的非可视区域内容到剪贴板，仅缓存当前文档视图内可见的表格片段
2. 固定偏移40行的逻辑没有适配不同表格的实际高度，容易出现后续表格内容和前序表格重叠的问题

Dim write_row As Long
Dim tableObject As Object
Dim tableItem As Object
Dim WordApp As Object
Dim WordDoc As Object
Dim pastedPic As Shape

' 后期绑定启动Word，无需提前加载Word类库引用
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
WordApp.ScreenUpdating = False

Set WordDoc = WordApp.Documents.Open(Filename:="C:\Users\test.docx", ReadOnly:=True)
Set tableObject = WordDoc.Content.Tables

write_row = 1

For Each tableItem In tableObject
    ' 全选当前表格，强制Word加载完整表格内容
    tableItem.Select
    WordApp.Selection.Copy
    DoEvents ' 等待剪贴板完成全量内容写入，避免截断
    
    ' 以增强型图元文件格式粘贴图片，清晰度高文件体积小
    ActiveSheet.PasteSpecial Format:="Picture (Enhanced Metafile)", Link:=False, DisplayAsIcon:=False
    Set pastedPic = ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
    
    ' 对齐图片到对应单元格位置
    pastedPic.Top = Cells(write_row, 1).Top
    pastedPic.Left = Cells(write_row, 1).Left
    
    ' 按图片实际高度动态计算下一个表格的起始粘贴位置，预留2行空白间隔
    write_row = write_row + WorksheetFunction.Ceiling(pastedPic.Height / ActiveSheet.RowHeight, 1) + 2
Next

' 清理剪贴板和Word进程
Application.CutCopyMode = False
WordDoc.Close SaveChanges:=False
WordApp.Quit

' 释放对象内存，避免后台残留WINWORD.EXE进程
Set tableItem = Nothing
Set tableObject = Nothing
Set WordDoc = Nothing
Set WordApp = Nothing

• 请将代码中的文件路径C:\Users\test.docx替换为你本地实际的Word文件路径
• 代码默认将所有表格按顺序纵向粘贴到当前活动工作表，每个表格之间自动留2行空白，不会重叠
• 增强型图元文件格式的图片清晰度远高于普通位图，且文件体积更小，适合内容核验场景
• 如果后续需要保留可编辑的表格格式而非图片，只需将粘贴逻辑替换为Cells(write_row, 1).PasteSpecial Paste:=xlPasteAllUsingSourceTheme即可，同样可以解决内容截断问题
• 行号变量使用Long类型，避免旧版VBA中Integer类型最大仅支持32767行导致的溢出报错

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