excel如何快速拆分vba文件（用VBA批量转换Excel格式）

Excel2007以前的格式是.xls，之后的格式是.xlsx。打开单独的一个Excel文档，使用“另存为”功能，可以很轻松的转换格式。但是面对几百个Excel表这样就太累了，搜索很久，也没发现一个工具可以直接批量进行格式转换。

最终发现可以使用VBA来实现批量转换Excel格式的功能。大家不要被吓到，VBA我也不懂，代码是从别人那里搞到的，现在也只是知道了怎么使用，但这足够解决问题了

VBA介绍：

1、VBA是一种编程语言，它依托于Office软件，不能独立的运行，通过VBA可以实现各种Office软件操作的自动化。

2、Visual Basic for Applications(VBA)是Visual Basic的一种宏语言，主要能用来扩展Windows的应用程式功能。使用Excel的VBA开发的Excel文档，在Excel中运行时需要开启Excel的宏功能，否则此文档的VBA自动化功能将被完全屏蔽，文档的功能无法实现。

执行条件：

1、Office2007及以上版本的Excel

2、Excel启用宏

功能介绍：

先介绍这两个工具功能，大家可以根据需要下载。

【xls-To-xlsx.xlsm】

会在所在文件夹目录中、包括子目录中，遍历所有.xls格式的文件，执行“另存为”操作，然后在原文件当前位置另存为一个同名的.xlsx格式的文件。

比如：

执行前【xls-To-xlsx.xlsm】所在的文件夹中有4个.xls格式的文件;

同时包含一个子文件夹，子文件夹中也有4个.xls格式的文件。

执行后，会生成如下(红色虚线内标注)文件：

【Convert-TO-xlsx.xlsm】

会在所在文件夹目录中(不包括子目录)，遍历所有.xls格式的文件，执行“另存为”操作，然后在当前路径下生成一个xlsx的文件夹，这个文件夹中放了所有新生成的文件。

比如：

执行前【Convert-TO-xlsx.xlsm】所在的【Convert-TO-xlsx】文件夹中有4个.xls格式的文件

执行后，会生成如下(红色虚线内标注)文件：

执行方法：

1、下载附件，或者新建一个Excel;

2、启用宏操作

一般情况下，打开Excel的时候，会弹出如下警告，如果弹出了这个警告，直接启用就可以了;

如果没有出现的话，请参考《Excel怎样设置启用宏功能》文章

3、编写执行VBA代码

这一步新手肯定是不会的，详细的图文介绍就参考《Excel VBA 概述》文章。

这里只作简单的说明：

• (a) 在工作表界面按下组合快捷键【Alt F11】或者【右键单击任意一个工作表标签，在弹出的右键快捷菜单单击“查看代码”】进入VBA编辑环境
• (b) 如果是下载的我的工具，可以跳过此步骤；如果是新建的Excel，此时在VBA编辑环境中的“代码窗口”复制粘贴下方 VBA代码内容【xls-To-xlsx.xlsm】VBA代码内容 或者《Convert-TO-xlsx.xlsm》VBA代码内容两个代码中的一个
• (c) 按下【F5】快捷键执行这段代码或者在菜单中单击【运行子过程/用户窗体(F5)】按钮

PS：需要说明的是，在执行过程中，不要去做其他的操作，不然可能会中断程序的运行

VBA代码内容

【xls-To-xlsx.xlsm】VBA代码内容

'***********访问当前文件夹目录下所有子文件夹及文件, Dim iFile(1 To 100000) As String Dim count As Integer Sub xls2xlsx() iPath = ThisWorkbook.Path On Error Resume Next count = 0 zdir iPath For i = 1 To count If iFile(i) Like "*.xls" And iFile(i) <> ThisWorkbook.FullName Then '请注意区分目录下文件后缀.xls大小写 MyFile = iFile(i) FilePath = Replace(MyFile, ".xls", ".xlsx") '请注意区分目录下文件后缀.xls大小写 If Dir(FilePath, 16) = Empty Then Set WBookOther = Workbooks.Open(MyFile) Application.ScreenUpdating = False ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False WBookOther.Close SaveChanges:=False '解决不能close 文件问题 Application.ScreenUpdating = True End If End If Next End Sub Sub zdir(p) '访问当前文件夹下所有子文件夹及文件 Set fs = CreateObject("scripting.filesystemobject") For Each f In fs.GetFolder(p).Files If f <> ThisWorkbook.FullName Then count = count 1: iFile(count) = f Next For Each m In fs.GetFolder(p).SubFolders zdir m Next End Sub

《Convert-TO-xlsx.xlsm》VBA代码内容

Sub xls2xlsx() Dim FilePath, MyFile, iPath, Name, OutPath As String iPath = ThisWorkbook.Path OutPath = Dir(iPath & "\xlsx", vbDirectory) If OutPath = "" Then MkDir (iPath & "\xlsx") End If MyFile = Dir(iPath & "\*.xls") If MyFile <> "" Then Do On Error Resume Next If MyFile = ThisWorkbook.Name Then MyFile = Dir Workbooks.Open (iPath & "\" & MyFile) MyFile = Replace(MyFile, ".xls", ".xlsx") Name = "\" & MyFile FilePath = iPath & "\xlsx" & Name Application.ScreenUpdating = False ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False Workbooks(MyFile).Close True Application.ScreenUpdating = True MyFile = Dir Loop While MyFile <> "" End If End Sub

后来有同学提了些问题，最后执行代码的时候，并没有达到效果。

先来看下正常的效果，会先弹出一个对话框，然后运行

出问题的原因是：

在使用过程中请留意Excel的后缀名【.xls 或 .XLS】大小写区分。如果后缀大小写不区分会导致了代码不能执行或执行以后无效果。

针对这种情况只要将代码中的后缀名大小写与文件夹中的文件的后缀改成相同就可以了。

还可以用《拖把更名器》软件，批量将文件后缀名改为小写后再进行操作。

如果再使用过程中遇到什么问题，请在下方留言。

,