VBA: 使用递归法将xls文件批量转化为xlsm文件

文章背景： 根据工作的需要，早期内部根据不同需求设置了很多模板文件，都是xls格式。相比于xlsm文件，采用xls格式存在一些不足之处：一是保存同样的内容，xls文件占用空间相对更大；二是xls文件能支持的单元格格式个数是4,000；而xlsm文件能支持的单元格格式个数是64,000。因此，有必要将xls文件另存为xlsm文件。

由于文件夹内有二三十份xls文件，如果一个个打开xls文件，另存为xlsm格式，这样操作起来比较费时费力。因此，打算通过编写VBA代码来进行任务的实现。

通过Excel VBA的UserForm控件来设置界面。

点击各个控件，添加如下代码（修改路径按钮对应CommandButton6,批量转化按钮对应CommandButton8）：

代码语言：javascript复制

Option Explicit

Private Sub CommandButton6_Click()

    '修改文件夹路径

    With Application.FileDialog(filedialogtype:=msoFileDialogFolderPicker)
    
        .InitialFileName = "E:报告模板"             '设置起始目录
        .AllowMultiSelect = True                    '单选
        .Title = "请选新的文件夹路径"               '设置对话框标题
        .Show                                       '显示对话框
        
        If .SelectedItems.Count > 0 Then
        
            TextBox1.Text = .SelectedItems(1)       '将选中的文件夹路径添加到文本框
            
        Else
        
            MsgBox "没有选择目录！"
            
        End If
        
    End With

End Sub

Private Sub CommandButton8_Click()

    '批量转化

    Dim folder As String
    
    Dim fso As Object, fld As Object
    
    Dim time_ini As Date
    
    '1 准备工作
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    time_ini = Timer
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    
    '2 遍历文件夹
    folder = TextBox1.Text
    If fso.FolderExists(folder) Then
    
        Set fld = fso.GetFolder(folder)
        
        LookUpAllFiles fld
        
    Else
    
        MsgBox folder & "文件夹路径不存在，请确认！"
        
    End If
    
    MsgBox "Done!  " & vbCrLf & vbCrLf & "用时：" & Format(Timer - time_ini, "0.0s")
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    Exit Sub

End Sub

Sub LookUpAllFiles(fld As Variant)

    '遍历xls文件
    Dim fil, outFld
    
    For Each fil In fld.Files
    
        If fil.Name Like "*.xls" Then
        
            ConvertFile fld & "" & fil.Name
        
        End If
    
    Next
    
    For Each outFld In fld.subFolders
    
        LookUpAllFiles outFld       '递归法，调用自身
    
    Next

End Sub

Sub ConvertFile(filepath As String)

    '将xls文件转化为xlsm文件
    Dim sName As String
    
    With Workbooks.Open(filepath)
    
        sName = Dir(filepath & "m")
        If Len(sName) Then
    
            MsgBox filepath & "m" & vbCrLf & vbCrLf & "同名文件已存在，本批次结束后请确认！"
        
        Else
    
            .SaveAs Filename:=filepath & "m", FileFormat:=xlOpenXMLWorkbookMacroEnabled
            
        End If
        
        '关闭工作簿
        .Close SaveChanges:=False
    
    End With
    
    '删除xls文件
    Kill filepath
                          
End Sub

Private Sub UserForm_Initialize()

    '窗口初始化
    TextBox1.Text = "E:报告模板"

End Sub

注意：上述代码将xls文件转化为xlsm文件的同时，删除原有的xls文件。因此，在批量转化之前，最好提前做好xls文件的备份，避免转化过程出错，导致原始文件的丢失。

参考资料：

[1] Workbook.SaveAs method (Excel) (https://docs.microsoft.com/en-us/office/vba/api/excel.workbook.saveas)

[2] Dir 函数 (https://support.microsoft.com/zh-cn/office/dir-函数-1a1a4275-f92f-4ae4-8b87-41e4513bba2e)

[3] 如何用vba删除文件 (http://www.exceloffice.net/archives/1507)

编程算法 vba windowsserver https http

0 人点赞