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

newenergy

没辙了。。自己挑战自己结果失败了。
现在要打印一套通知给各下属单位，所有文字内容已经经过邮件合并完成，现在需要在每封邮件的固定位置插入各单位相应的表格。
初步设想word内每一个单位的提示函为一小节（进行分页），在每小节（每页）的第7段定位插入表格，但是完全找不到相应的vba代码，特来求大大们帮助。

duquancai

VBA是可以做，但是需要附件，另外有空再做。当然手动也可以做，只是慢一点而已！

newenergy

duquancai 发表于 2018-3-20 16:49
VBA是可以做，但是需要附件，另外有空再做。当然手动也可以做，只是慢一点而已！

单位不允许上传一些东西，其实就是邮件合并之后生成几页大致文字内容相同的通知，在每页通知的第7段插入表格，只求怎么定位某节某段。

413191246se

1. Sub 第7段落前面插入表格()
   
2.     Dim s As Section
   
3.     With ActiveDocument
   
4.         For Each s In .Sections
   
5.             If s.Range.Paragraphs.Count = 1 Then Exit For
   
6.             If s.Range.Paragraphs.Count > 6 Then
   
7.                 s.Range.Paragraphs(7).Range.Select '选定每节每7段落
   
8.                 Selection.HomeKey unit:=wdLine
   
9.                 '插入2行3列表格
   
10.                 ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= _
    
11.                     3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:=wdAutoFitFixed
    
12.                 Selection.Tables(1).Style = "网格型"
    
13.             End If
    
14.         Next
    
15.     End With
    
16. End Sub

复制代码

newenergy

413191246se 发表于 2018-3-20 17:45

学习了。

newenergy

413191246se 发表于 2018-3-20 17:45

请问，如果需要在每节第7段插入已经复制好的不同表格呢，谢谢！

413191246se

楼主，你楼上的话还是说得不明白。——假设第1节复制A表格，第2节复制B表格，第3节复制C表格……，（还是只复制一张存在一个文档中的固定表格？）恐怕得手动了。——另外，楼主你可以上传一张图片，当然是专门处理过的，不要有你们单位名称（保密）。——请把话说透。

newenergy

413191246se 发表于 2018-3-21 13:57
楼主，你楼上的话还是说得不明白。——假设第1节复制A表格，第2节复制B表格，第3节复制C表格……，（还是只 ...

目前的任务是这样的：（1）在excel中，根据数据有效性，分别筛选每个单位的相关数据，表现在同一个表格区域内，比如A1：G20。（2）word文件内有这些单位分别对应的提示函内容，每个单位为一页或一节，具体内容由邮件合并产生。（3）最后一步，每次筛选一个单位，就复制A1：G20的表格粘贴到这个单位在word中对应页的第7段。现在只有第3步无法实现。目前我的代码是这样的：
Sub 生成()
Dim dpath, Filename As String
Dim wdapp As Object, wrddoc
Dim ws As Worksheet, arr
Dim rng As Range
Dim s As Section
On Error Resume Next
Set ws = Worksheets("选择")
Set wdapp = CreateObject("Word.Application")
  wdapp.Visible = 0
Application.ScreenUpdating = False
arr = ws.Range("B31:B" & ws.Range("B65536").End(xlUp).Row)
dpath = ThisWorkbook.Path
  Filename = Dir(dpath & "\正面.doc")
Set wrddoc = wdapp.Documents.Open(dpath & "\" & Filename) '打开word
i = 1
With ActiveDocument '调测
  For Each s In .Sections
    If s.Range.Paragraphs.Count = 1 Then Exit For
    If s.Range.Paragraphs.Count > 6 Then
      Do While i <= UBound(arr)
        Excel.Application.Sheets("选择").Activate
        [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
          s.Range.Paragraphs(7).Range.Paste
        i = i + 1
      Exit Do
  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

413191246se 发表于 2018-3-21 13:57
楼主，你楼上的话还是说得不明白。——假设第1节复制A表格，第2节复制B表格，第3节复制C表格……，（还是只 ...

有底色的部分属于表格操作部分，可以无视，最后出来的效果就是筛选后填充到表格固定区域内

413191246se

好麻烦！还得EXCEL和WORD联合通讯，这个我一点儿也不会。我一般是把数据放在WORD表格中，这样全在WORD中处理没有什么障碍。——有不会的话继续发问，坐等 杜先生 或其他各位高人来回复。