20170714xlVba多个工作簿转多个Word文档表格

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
Public Sub SameFolderGather()
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = ">>>>>程序正在转化,请耐心等候>>>>>"
 
    'On Error GoTo ErrHandler
 
    Dim StartTime, UsedTime As Variant
    StartTime = VBA.Timer
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Dim Wb As Workbook
    Dim Sht As Worksheet
    Dim OpenWb As Workbook
    Dim Opensht As Worksheet
    Const SHEET_INDEX = 1
    Const OFFSET_ROW As Long = 1
 
    Dim FolderPath As String
    Dim FileName As String
    Dim FileCount As Long
 
    Dim ModelPath As String
    Dim NewFolder As String
    Dim NewFile As String
    Dim NewPath As String
 
 
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    Set Wb = Application.ThisWorkbook    '工作簿级别
    Set Sht = Wb.Worksheets("汇总")
    Sht.UsedRange.Offset(1).Clear
    FolderPath = Wb.Path & "\Excel表格\"
    ModelPath = Wb.Path & "\Word模板\调查统计表空表.doc"
 
    NewFolder = Wb.Path & "\Word表格\"
    '绑定
    Dim wdApp As Object
    Dim wdTb As Object
    Dim wdDoc As Object
    Set wdApp = CreateObject("Word.Application")
 
 
 
    FileCount = 0
    FileName = Dir(FolderPath & "*.xls*")
    Do While FileName <> ""
        If FileName <> ThisWorkbook.Name Then
            FileCount = FileCount + 1
 
            NewFile = Split(FileName, ".")(0) & ".doc"
            NewPath = NewFolder & NewFile
 
 
            Set OpenWb = Application.Workbooks.Open(FolderPath & FileName)
            With OpenWb
                Set Opensht = OpenWb.Worksheets(SHEET_INDEX)
 
                With Opensht
                    Dim Arr(1 To 17) As String
                    tx = .Range("A2").Text
                    Arr(1) = Replace(Split(tx, "区")(0), " ", "")
                    Arr(2) = Replace(Split(Split(tx, "区")(1), "社")(0), " ", "")
                    Arr(3) = .Range("B3").Value
                    Arr(4) = .Range("D3").Value
                    Arr(5) = .Range("B4").Value
                    Arr(6) = .Range("D4").Value
                    Arr(7) = .Range("F4").Value
                    Arr(8) = .Range("B5").Value
                    Arr(9) = .Range("E5").Value
                    Arr(10) = .Range("B6").Value
                    Arr(11) = .Range("B7").Value
                    Arr(12) = .Range("B8").Value
                    Arr(13) = .Range("B9").Value
                    Arr(14) = .Range("B10").Value
                    Arr(15) = .Range("B11").Value
                    tx = .Range("A14").Text
                    Arr(16) = Replace(Split(Split(tx, "填表日期")(0), ":")(1), " ", "")
                    Arr(17) = Replace(Split(tx, "填表日期:")(1), " ", "")
 
                    Sht.Cells(FileCount + 1, 1).Resize(1, 17).Value = Arr
 
                    Set wdDoc = wdApp.Documents.Open(ModelPath)
                    Set wdTb = wdDoc.Tables(1)
                    With wdTb
                        .Cell(1, 2).Range.Text = Arr(3)  '姓名
                        .Cell(1, 4).Range.Text = Arr(4)     '住址
                        .Cell(2, 2).Range.Text = Arr(5)     '性别
                        .Cell(2, 4).Range.Text = Arr(6)     '出生
                        .Cell(2, 6).Range.Text = Arr(7)     '年龄
                        .Cell(3, 2).Range.Text = Arr(8)     '手机
                        .Cell(3, 4).Range.Text = Arr(9)     '固话
                        .Cell(4, 2).Range.Text = Arr(10)     '子女手机
                        .Cell(5, 2).Range.Text = Arr(11)     '家庭
                        .Cell(6, 2).Range.Text = Arr(12)     '经济
                        .Cell(7, 2).Range.Text = Arr(13)     '健康
                        .Cell(8, 2).Range.Text = Arr(14)     '服务
                        .Cell(9, 2).Range.Text = Arr(15)     '服务时间
                    End With
                  wdDoc.SaveAs NewPath
                  wdDoc.Save
                  wdDoc.Close
 
                End With
 
                .Close False
            End With
        End If
        FileName = Dir
    Loop
     
     
    wdApp.Quit
     
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
    UsedTime = VBA.Timer - StartTime
    MsgBox "本次耗时:" & Format(UsedTime, "0.000秒"), vbOKOnly, "NextSeven Excel Studio QQ嘻嘻哈哈"
 
ErrorExit:
    Set Wb = Nothing
    Set Sht = Nothing
    Set OpenWb = Nothing
    Set Opensht = Nothing
    Set Rng = Nothing
       
    Set wdApp = Nothing
    Set wdDoc = Nothing
    Set wdTb = Nothing
 
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
    Exit Sub
    '>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
ErrHandler:
    If Err.Number <> 0 Then
        MsgBox Err.Description & "!", vbCritical, "NextSeven Excel Studio QQ嘻嘻哈哈"
        'Debug.Print Err.Description
        Err.Clear
        Resume ErrorExit
    End If
End Sub

  

posted @   wangway  阅读(144)  评论(0编辑  收藏  举报
点击右上角即可分享
微信分享提示