Question

我有一本充满工作表的工作簿我试图将内容复制并粘贴到word文档中。现在，代码循环遍历所有工作表并将它们粘贴到word文档中，但相互叠加。我必须将wdDoc.Range(wdDoc.Characters.Count - 1).Paste更改为wdDoc.Range(wdDoc.Characters.Count - 1).PasteExcelTable False, False, False，我不确定这是否是问题的根源;它似乎正在创建一个新页面，但下一个工作表的内容并没有被粘贴到它中。我没有收到任何错误消息。任何建议将不胜感激！

Sub toWord()
Dim ws As Worksheet
Dim fromWB As Variant
Dim wdApp As Object
Dim wdDoc As Object
Dim docName As Variant
Dim rng As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False


Set wdApp = CreateObject("Word.Application")
 wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add
wdDoc.Activate
'Creates InputBox that allows user to enter name to save document as
docName = Application.InputBox(Prompt:="Enter Document Name", Title:="Save Word Document", Type:=2)
wdDoc.SaveAs2 fileName:=docName, FileFormat:=wdFormatDocument 'Saves document under user-provided name

fromWB = Application.GetOpenFilename(FileFilter:="Excel Workbook(*.xlsx),*.xlsx", Title:="Open Merged Data")
If fromWB <> False Then
Set fromWB = Workbooks.Open(fromWB)
ElseIf fromWB = False Then
    MsgBox "No File Selected"
    GoTo ResetSettings
End If


For Each ws In fromWB.Worksheets
    ws.Activate
    ws.Range("A1:A2").Select
    Selection.Copy
    Set wdApp = GetObject(, "Word.Application")
    wdApp.Visible = True
    wdDoc.Activate
    wdDoc.Range.Paste

    ws.Activate

    If ws.Range("A3").Value <> "" Then
    Range("A2").CurrentRegion.Offset(2).Resize(Range("A2").CurrentRegion.Rows.Count - 2).Select
    Selection.Columns.AutoFit
    Selection.Copy
    Set wdApp = GetObject(, "Word.Application")
    wdApp.Visible = True
    wdDoc.Activate
    wdApp.Selection.EndKey Unit:=wdStory
    wdApp.Selection.MoveDown Unit:=wdLine, Count:=1
    wdApp.Selection.TypeParagraph
    wdDoc.Range(wdDoc.Characters.Count - 1).PasteExcelTable False, False, False
    wdApp.Selection.Tables(1).Rows.Alignment = wdAlignRowCenter


    wdDoc.Range.Collapse Direction:=0
    wdDoc.Range(wdDoc.Characters.Count - 1).InsertBreak Type:=7
   End If
Next ws

wdDoc.Styles("Normal").NoSpaceBetweenParagraphsOfSameStyle = True
wdDoc.Save
Set wdDoc = Nothing
Set wdApp = Nothing
Set fromWB = Nothing
MsgBox "Imported into Word Document"


ResetSettings:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub

Answer 1

测试时占位符编辑：

Sub asdf()
    Dim ws As Worksheet
    Const wdStory = 6
    Const wdMove = 0

    For Each ws In ThisWorkbook.Worksheets
        ws.Range("A7").Copy
        Set docApp = GetObject(, "Word.Application")
        Set doc = docApp.Documents.Open("PATH OF FILE")
        docApp.Selection.EndKey wdStory
        docApp.Selection.PasteAndFormat wdPasteDefault
    Next ws

End Sub

Answer 2

这是我开始工作的代码：

Sub toWord()
Dim ws As Worksheet
Dim fromWB As Variant
Dim wdApp As Object
Dim wdDoc As Object
Dim docName As Variant
Dim rng As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False


Set wdApp = CreateObject("Word.Application")
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Add
wdDoc.Activate
'Creates InputBox that allows user to enter name to save document as
docName = Application.InputBox(Prompt:="Enter Document Name", Title:="Save Word Document", Type:=2)
wdDoc.SaveAs2 fileName:=docName, FileFormat:=wdFormatDocument 'Saves document under user-provided name

fromWB = Application.GetOpenFilename(FileFilter:="Excel Workbook(*.xlsx),*.xlsx", Title:="Open Merged Data")
If fromWB <> False Then
Set fromWB = Workbooks.Open(fromWB)
ElseIf fromWB = False Then
    MsgBox "No File Selected"
    GoTo ResetSettings
End If

For Each ws In fromWB.Worksheets
    ws.Activate
    ws.Range("A1:A2").Select
    Selection.Copy
    Set wdApp = GetObject(, "Word.Application")
    wdApp.Visible = True
    wdDoc.Activate
    wdDoc.Range(wdDoc.Characters.Count - 1).Paste

    ws.Activate
    If ws.Range("A4").Value <> "" Then
    Application.Intersect(ws.UsedRange, ws.Cells.Resize(ws.Rows.Count - 2).Offset(2)).Select
    Selection.Columns.AutoFit
    Selection.Copy
    Set wdApp = GetObject(, "Word.Application")
    wdApp.Visible = True
    wdDoc.Activate
    wdApp.Selection.EndKey Unit:=wdStory
    wdApp.Selection.MoveDown Unit:=wdLine, Count:=1
    wdApp.Selection.TypeParagraph
    wdDoc.Range(wdDoc.Characters.Count - 1).PasteExcelTable False, False, False
    wdApp.Selection.Tables(1).Rows.Alignment = wdAlignRowCenter
    wdApp.Selection.Collapse Direction:=0
    wdDoc.Range(wdDoc.Characters.Count - 1).InsertBreak Type:=7
   Else
   wdDoc.Range(wdDoc.Characters.Count - 1).InsertBreak Type:=7
   End If
Next ws

wdDoc.Styles("No Spacing").NoSpaceBetweenParagraphsOfSameStyle = True
wdDoc.Save
Set wdDoc = Nothing
Set wdApp = Nothing
Set fromWB = Nothing
MsgBox "Imported into Word Document"


ResetSettings:
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True

End Sub

Excel VBA分页符

2 个答案: