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