在邮件合并完成文字内容后的word中每小节第7段插入表格

newenergy

413191246se 发表于 2018-3-21 17:36
好麻烦！还得EXCEL和WORD联合通讯，这个我一点儿也不会。我一般是把数据放在WORD表格中，这样全在WORD中处 ...

我这个基础数据量比较大，还要牵扯到一个筛选相应单位的过程，word表格里放不下也不好筛选。所以才想到这个流程。之前实现了3页的粘贴， 结果我改动了一点程序又不能粘贴了，不知道什么原因。现在的代码：
Sub 生成()
Dim dpath, Filename As String
Dim wdapp As Object, wrddoc, arr, i
Dim rng As Range
Dim s As Section

On Error Resume Next
Application.ScreenUpdating = False
arr = Worksheets("选择").Range("B31:B" & ws.Range("B65536").End(xlUp).Row)

Set wdapp = CreateObject("Word.Application") '打开word
  wdapp.Visible = 0
dpath = ThisWorkbook.Path
  Filename = Dir(dpath & "\正面.doc")
Set wrddoc = wdapp.Documents.Open(dpath & "\" & Filename)

i = 1
With ActiveDocument '调测
  For Each s In .Sections
    If s.Range.Paragraphs.Count <= 6 Then Exit For
    If s.Range.Paragraphs.Count > 6 Then
      Excel.Application.Sheets("选择").Activate '激活excel
      If i <= UBound(arr) Then
        [K4] = arr(i, 1)
        Sheets("处理").Columns("A:G").AdvancedFilter Action:=xlFilterCopy, _
          CriteriaRange:=Range("K3:K4"), CopyToRange:=Range("A2:G20"), Unique:= _
        False
        
        ActiveWindow.SmallScroll Down:=3
        Range("B3:G20").Select
        ActiveWorkbook.Worksheets("选择").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("选择").Sort.SortFields.Add Key:=Range( _
           "B3:B20"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
        
        With ActiveWorkbook.Worksheets("选择").Sort
          .SetRange Range("B3:G20")
          .Header = xlGuess
          .MatchCase = False
          .Orientation = xlTopToBottom
          .SortMethod = xlPinYin
          .Apply
        End With
        Sheets("选择").Range("B1:G" & Sheets("选择").Range("G65536").End(xlUp).Row).Copy
        
        wdapp.Application.Activate '回到word粘贴.
        s.Range.Paragraphs(7).Range.Paste
        i = i + 1
      End If
    End If
  Next
End With


wdapp.Application.Activate '保存word文件
wdapp.Saved = True
wdapp.ActiveDocument.SaveAs "D:\插入后文件.doc"
wdapp.Application.Quit
Set wdapp = Nothing
   
Application.ScreenUpdating = True
End Sub

newenergy

现在的问题是直接不复制粘贴了，哪里出问题了，有大神救我一下么。。
Sub 生成()
Dim i As Integer
Dim dpath, Filename As String
Dim wdapp As Object, wrddoc, arr
Dim rng As Range
Dim s As Section
i = 1

On Error Resume Next
Application.ScreenUpdating = False
arr = Worksheets("选择").Range("A31:A" & ws.Range("A65536").End(xlUp).Row)

Set wdapp = CreateObject("Word.Application") '打开word
  wdapp.Visible = 0
dpath = ThisWorkbook.Path
  Filename = Dir(dpath & "\正面.doc")
Set wrddoc = wdapp.Documents.Open(dpath & "\" & Filename)

With ActiveDocument '调测
  For Each s In .Sections
    If s.Range.Paragraphs.Count > 6 Then
      i = i + 1
      Excel.Application.Sheets("选择").Activate '激活excel
      Do While i <= UBound(arr)
        [K4] = arr(i, 1)
        Sheets("处理").Columns("A:G").AdvancedFilter Action:=xlFilterCopy, _
          CriteriaRange:=Range("K3:K4"), CopyToRange:=Range("A2:G20"), Unique:= _
        False
        
        ActiveWindow.SmallScroll Down:=3
        Range("B3:G20").Select
        ActiveWorkbook.Worksheets("选择").Sort.SortFields.Clear
        ActiveWorkbook.Worksheets("选择").Sort.SortFields.Add Key:=Range( _
           "B3:B20"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
        xlSortNormal
        
        With ActiveWorkbook.Worksheets("选择").Sort
          .SetRange Range("B3:G20")
          .Header = xlGuess
          .MatchCase = False
          .Orientation = xlTopToBottom
          .SortMethod = xlPinYin
          .Apply
        End With
        Sheets("选择").Range("B1:G" & Sheets("选择").Range("B65536").End(xlUp).Row).Copy
        
        wdapp.Application.Activate '回到word粘贴.
        s.Range.Paragraphs(7).Range.Paste
        Exit Do
      Loop
    End If
    If s.Range.Paragraphs.Count = 1 Then Exit For
  Next
End With


wdapp.Application.Activate '保存word文件
wdapp.Saved = True
wdapp.ActiveDocument.SaveAs "D:\插入后文件.doc"
wdapp.Application.Quit
Set wdapp = Nothing
   
Application.ScreenUpdating = True
End Sub