但我引用的这个Range仍是Word的内容啊
以下是全部代码
Sub WordToExcel() Dim MyRange As Range, i As Integer, StRange As Long, EndRange As Long, Pages As Integer Dim AppWord As Word.Application, Wk As Excel.Workbook, Wksh As Excel.Worksheet, ShCount As Integer On Error Resume Next '错误忽略 Application.ScreenUpdating = False '关闭屏幕更新 Set AppWord = CreateObject("Word.Application") '创建新Excel程序 Set Wk = ActiveWorkbook '一个新的工作薄 ' ShCount = Wk.Sheets.Count 'WK的工作表数量 With ActiveDocument '活动WORD文档的总页数 Pages = .Content.Information(wdNumberOfPagesInDocument) .Range(0, 0).Select '将光标位置定位于0点 For i = 1 To Pages '从首页到尾页循环 If i <= 3 Then '如果i不大于当前工作薄的工作表数量时 Wk.Sheets(i).Activate '激活相应工作表 Else '新增工作表,位于最后位置 Set Wksh = Wk.Sheets.Add(After:=Wk.Sheets(Wk.Sheets.Count)) End If StRange = Selection.Start '获得光标起点位置 If i = Pages Then '如果循环到达最后一页 EndRange = .Content.End '止点位置为文档末位置 Else EndRange = Selection.GoToNext(wdGoToPage).Start '否则止点位置为下一页的起点,相当于本页终点 End If Set MyRange = .Range(StRange, EndRange) '选定该区域 MyRange.Copy '复制该选定页内容 ActiveSheet.Paste '于EXCEL中粘贴 Selection.Rows.AutoFit Selection.Columns.AutoFit Columns("A:A").Select Selection.ColumnWidth = 28 Next End With '进行适当提示 MsgBox "分页复制工作结束,请自行保存该工作薄!", vbOKCancel + vbInformation AppExcel.Visible = True '使其可见(先前不可见,可加快运行速度) Application.ScreenUpdating = True '恢复屏幕更新
End Sub
|