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文件中执行，这种形式是多线程执行，速度比较快

1.新建一个Excel文件

2.Alt + F11

3.Alt + im

4.鼠标点击到首行

5.点击运行-->运行子过程或用户窗体

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