Excel格式转化工具
背景
最近做项目,业务有几百个Excel文件需要上传到系统,由于是薪酬数据内容保密,原始文件不能提供,给了Excel 2007格式的测试数据。
用java代码解析Excel 2007格式,开发完成之后进入UAT,客户测试时说原始文件格式是Excel 2003版本的,给的文件是转化之后的,无奈之下
重新开发Excel 2003版本解析,代码写完交付UAT测试,发现异常,排查原因Excel 2003的原始数据竟然是html格式的文本文件,
实在不想再写java代码去解析html格式的Excel 2003了,因此用VB做了这个小工具,实现文件格式批量转化。
工具和源代码下载地址
https://pan.baidu.com/s/16346pcwKXX3oRXA0GtcWlQ
页面
代码
Rem 加载目标文件格式 Private Sub Form_Load() TypeList.List(0) = "Excel 2003" TypeList.List(1) = "Excel 2007" End Sub Rem 格式转换过程 Private Sub Convert_Click() Rem 定义变量:源文件夹路径、目标文件夹路径、目标文件格式、目标文件名后缀 Dim SourceDir$, TargetDir$, ExcelTypeIn$, suffix$ Rem 判断源文件夹路径是否存在 SourceDir = Text1.Text If Dir(SourceDir, vbDirectory) = "." Then MsgBox "源文件夹路径不能为空!" Exit Sub ElseIf Dir(SourceDir, vbDirectory) = "" Then MsgBox "源文件夹路径" & SourceDir & "不存在!" Exit Sub End If SourceDir = SourceDir & "\" Rem 判断目标文件夹路径是否存在 TargetDir = Text2.Text If Dir(TargetDir, vbDirectory) = "." Then MsgBox "目标文件夹路径不能为空!" Exit Sub ElseIf Dir(TargetDir, vbDirectory) = "" Then MsgBox "目标文件夹路径" & TargetDir & "不存在!" Exit Sub End If TargetDir = TargetDir & "\" Rem 判断源文件夹路径和目标文件夹路径是否相等 If SourceDir = TargetDir Then MsgBox "源文件夹路径和目标文件夹路径不能相等!" Exit Sub End If Rem 判断目标文件的格式 ExcelTypeIn = Val(TypeList.ListIndex) If ExcelTypeIn = "0" Then suffix = ".xls" ElseIf ExcelTypeIn = "1" Then suffix = ".xlsx" Else MsgBox "请选择目标文件格式!" Exit Sub End If Rem 当前系统安装什么Excel就获得相应的excel.application Dim ExApp As Object Set ExApp = CreateObject("excel.application") ExApp.Application.ScreenUpdating = False Dim sourceFile$, targetFile$ sourceFile = Dir(SourceDir & "*.xls") Do While sourceFile <> "" targetFile = Left(sourceFile, InStr(sourceFile, ".") - 1) & suffix \'目标文件名称 Rem --------------------------具体转化过程开始---------------------------- ExApp.Workbooks.Open (SourceDir & sourceFile) ExApp.Application.DisplayAlerts = False If ExcelTypeIn = "0" Then ExApp.ActiveWorkbook.SaveAs TargetDir & targetFile, xlExcel8 \'转换为2003格式 ElseIf ExcelTypeIn = "1" Then ExApp.ActiveWorkbook.SaveAs TargetDir & targetFile, 51 \'转换为2007格式 End If ExApp.Application.DisplayAlerts = True ExApp.ActiveWorkbook.Close True Rem --------------------------具体转化过程结束---------------------------- sourceFile = Dir \'获得文件夹中的下一个文件 Loop ExApp.Application.ScreenUpdating = False MsgBox "文件夹内的所有Excel文件格式转换完毕!" End Sub Rem 结束按钮的事件程序 Private Sub CloseCmd_Click() End End Sub
方式二:在Excel文件中执行,这种形式是多线程执行,速度比较快
Private Sub Workbook_Open() Dim SourceDir$, TargetDir$, ExcelTypeIn$, suffix$ Rem ----------------------修改如下三个数据开始------------------------ SourceDir = "" \'源文件夹路径 TargetDir = "" \'目标文件夹路径 ExcelTypeIn = "0" \'0-Excel2003 1-Excel2007 Rem ----------------------修改如下三个数据结束------------------------ SourceDir = SourceDir & "\" TargetDir = TargetDir & "\" If ExcelTypeIn = "0" Then suffix = ".xls" ElseIf ExcelTypeIn = "1" Then suffix = ".xlsx" End If Application.ScreenUpdating = False Dim SourceFile$,targetFile$ SourceFile = Dir(SourceDir & "*.xls") Do While SourceFile <> "" targetFile = Left(sourceFile, InStr(sourceFile, ".") - 1) & suffix \'目标文件名称 If SourceFile <> ThisWorkbook.Name Then Workbooks.Open SourceDir & SourceFile Application.DisplayAlerts = False ActiveWorkbook.SaveAs TargetDir & targetFile, xlExcel8 Application.DisplayAlerts = True ActiveWorkbook.Close True End If SourceFile = Dir Loop Application.ScreenUpdating = False MsgBox "本文件夹内的所有Excel文件打开另存完毕!" End Sub