批量筛选数据并按顺序以表格形式插入word每小节第7段

newenergy

word文件就是一个简单的模板，每节10段，需要在每节的第7段插入筛选后的非空表格。
表格形式为：基础数据表（"处理"），筛选结果表（"选择"）
表大致样式为：

信息1	信息2	信息3	信息4	信息5	信息6	信息 7
筛选条件
结果1
结果2
结果3
...
...
...
...
共20行

目前代码为：（问题，表格可以排序，但word文件另存为后不显示粘贴内容，不清楚是粘贴部分出问题还是保存部分有问题，异或是屏幕刷新的问题？）

1. Sub 生成()
   
2. On Error Resume Next
   
3. 
   
4. Dim ws As Worksheet, arr
   
5.   Set ws = Worksheets("选择")
   
6. arr = Worksheets("选择").Range("B31:B" & ws.Range("B65536").End(xlUp).Row)
   
7. 
   
8. Dim dpath, Filename As String
   
9. Dim wdapp As Object
   
10. Set wdapp = CreateObject("Word.Application") '打开word
    
11.   wdapp.Visible = True
    
12. dpath = ThisWorkbook.Path
    
13.   Filename = Dir(dpath & "\正面.doc")
    
14. wdapp.Documents.Open (dpath & "" & Filename)
    
15. 
    
16. Dim s As Section
    
17. Dim i As Integer
    
18. i = 1
    
19. wdapp.Application.Activate
    
20. With ActiveDocument '调测
    
21.   For Each s In .Sections
    
22.     If s.Range.Paragraphs.Count < 2 Then Exit For
    
23.     If s.Range.Paragraphs.Count > 6 Then
    
24.       Excel.Application.Sheets("选择").Activate '激活excel
    
25.       If i <= UBound(arr) Then
    
26.         Application.ScreenUpdating = False
    
27.         [K4] = arr(i, 1)
    
28.         Sheets("处理").Columns("A:G").AdvancedFilter Action:=xlFilterCopy, _
    
29.           CriteriaRange:=Range("K3:K4"), CopyToRange:=Range("A2:G20"), Unique:= _
    
30.         False
    
31.         
    
32.         ActiveWindow.SmallScroll Down:=3
    
33.         Range("B3:G20").Select
    
34.         ActiveWorkbook.Worksheets("选择").Sort.SortFields.Clear
    
35.         ActiveWorkbook.Worksheets("选择").Sort.SortFields.Add Key:=Range( _
    
36.            "B3:B20"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
    
37.         xlSortNormal
    
38.         
    
39.         With ActiveWorkbook.Worksheets("选择").Sort
    
40.           .SetRange Range("B3:G20")
    
41.           .Header = xlGuess
    
42.           .MatchCase = False
    
43.           .Orientation = xlTopToBottom
    
44.           .SortMethod = xlPinYin
    
45.           .Apply
    
46.         End With
    
47.         Sheets("选择").Range("B1:G" & Sheets("选择").Range("G65536").End(xlUp).Row).Copy
    
48.         
    
49.         '回到word粘贴.
    
50.         s.Range.Paragraphs(7).Range.Paste
    
51.         i = i + 1
    
52.         Application.ScreenUpdating = True
    
53.       End If
    
54.       Else
    
55.         Exit For
    
56.     End If
    
57.   Next
    
58. End With
    
59. 
    
60. 
    
61. wdapp.Application.Activate '保存word文件
    
62. wdapp.Saved = True
    
63. wdapp.ActiveDocument.SaveAs "D:\插入后文件.doc"
    
64. wdapp.Application.Quit
    
65. Set wdapp = Nothing
    
66. 
    
67. End Sub
    

复制代码