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 |
【推荐】编程新体验,更懂你的AI,立即体验豆包MarsCode编程助手
【推荐】凌霞软件回馈社区,博客园 & 1Panel & Halo 联合会员上线
【推荐】抖音旗下AI助手豆包,你的智能百科全书,全免费不限次数
【推荐】博客园社区专享云产品让利特惠,阿里云新客6.5折上折
【推荐】轻量又高性能的 SSH 工具 IShell:AI 加持,快人一步