vba 当前文件名_Excel文件拆分和汇总（VBA）

不定期地总会有朋友问到Excel文件拆分或汇总的问题，毕竟大家都不会喜欢大量重复而又机械的操作。考虑到不一定会有Python、Matlab等环境，我们用自带的VBA来解决这个问题。

下面提供的拆分与汇总程序可配合使用，也可单独使用；使用时需启用宏。

本文不讨论使用第三方插件或Power Query的操作方法。

拆分工作簿

详细描述

将一个工作簿中的所有工作表分别保存至单独的工作簿中，且新保存的工作簿名称与原工作表名称相关(或一致)。

说人话：把一个Excel文件中的所有sheet页，每个都单独保存成一个文件，保存的文件名与原来sheet页的名称要有关系。

解决思路

遍历当前工作簿中的所有工作表，复制后另存为工作簿，直至遍历完成。

操作步骤

1. 打开需要拆分的文件；
2. 打开VBA编辑窗口：

• 方法一：按组合键【Alt+F11】，选择菜单“插入”“模块”；
• 方法二：随机选中某一工作表标签，右键，选择快捷菜单中的“查看代码”；

3. 输入(复制粘贴)以下代码；
4. 按快捷键【F5】或点击工具栏的“运行宏”按钮，执行代码。

'文件拆分Sub SplitWorkbook()	'变量	Dim File_Path 		As String	'当前工作簿路径	Dim File_dir 		As String	'拆分文件路径	Dim File_str 		As String	'当前文件名称，不含扩展名	Dim File_Full_Name 	As String	'拆分后文件名称，含路径	Dim Path_Separator	As String	'路径分隔符	Dim Num		As Long	'计数器	'禁用屏幕刷新	Application.ScreenUpdating = False	'变量赋值	Path_Separator = Application.PathSeparator	File_Path = ThisWorkbook.Path	File_str = Left(ThisWorkbook.Name, Application.Find(".", ThisWorkbook.Name) - 1)	File_dir = File_Path & Path_Separator & File_str & "_拆分文件"	Num = 0	'判断拆分文件路径是否存在，如不存在，则创建	If Dir(File_dir, vbDirectory) = "" Then		'创建路径		MkDir File_dir	End If		'遍历工作表	For Each sht In ThisWorkbook.Worksheets		sht.Copy		'拆分后文件名赋值		File_Full_Name = File_dir & Path_Separator & File_str & "_" & sht.Name & ".xls"		'判断拆分文件是否存在，如存在，则删除		If Dir(File_Full_Name) <> "" Then			Kill File_Full_Name		End If		'另存文件		ActiveWorkbook.SaveAs Filename:=File_Full_Name, FileFormat:=xlNormal		ActiveWindow.Close		Num = Num + 1	Next	'提示	MsgBox "共拆分了 " & Num & " 个文件。" & Chr(13) & "存储路径：" & File_dir & " 。", vbInformation, "提示"		'启用屏幕刷新	Application.ScreenUpdating = True	'关闭警告提示	Application.DisplayAlerts = False	'关闭窗口	ActiveWindow.Close	'打开警告提示	Application.DisplayAlerts = TrueEnd Sub

汇总工作簿

详细描述

将同一目录下所有工作簿中的工作表汇总至一个工作簿中，汇总后工作簿中的工作表名称与原工作簿名称相关(或一致)。

说人话：把一个文件夹下所有Excel文件中的sheet页汇总到一个Excel文件中，汇总文件的sheet页名称与原来Excel文件名称要有关系。

解决思路

打开某一工作簿，获取所在目录下其他Excel文件，依次打开并读取工作表添加至当前工作簿后关闭，最后将当前工作簿另存为汇总工作簿(当前工作簿不作修改)。

操作步骤

1. 打开某一待汇总文件；
2. 打开VBA编辑窗口：

• 方法一：按组合键【Alt+F11】，选择菜单“插入”“模块”；
• 方法二：随机选中某一工作表标签，右键，选择快捷菜单中的“查看代码”；

3. 输入(复制粘贴)以下代码；
4. 按快捷键【F5】或点击工具栏的“运行宏”按钮，执行代码。

注：以下程序仅支持待汇总工作簿中只有一个工作表的情况

'同类文件合并Sub MergeWorkbook()	'变量	Dim FileNames 		As String 		'所有需合并文件名	Dim Path_Separator	As String		'路径分隔符	Dim FileOpen 		As Workbook		'待打开工作簿	Dim SheetData 		As Worksheet		'源数据工作表	Dim	Path_Current	As String		'当前文件路径	Dim Path_Temp		As String	Dim Num		As Long		'计数器	'禁用屏幕刷新	Application.ScreenUpdating = False  	'赋值	Path_Separator = Application.PathSeparator	'获取当前文件路径	Path_Current = ThisWorkbook.Path	'当前路径下所有Excel文件	FileNames = Dir(Path_Current & Path_Separator & "*.xls*")	'计数器初始化	Num = 1	'根据当前文件路径生成汇总文件路径	Path_Temp = Mid(Path_Current, 1, InStrRev(Path_Current, Path_Separator))	If Path_Temp <> "" Then		FilePath = Path_Temp	Else		FilePath = ThisWorkbook.Path	End If	'根据当前文件路径生成汇总文件名称	Name_temp = Replace(Mid(Path_Current, InStrRev(Path_Current, Path_Separator) + 1), "_拆分文件", "")	'文件名称。如果数据源中有工作表超过65536行，扩展名称改为：xlsm。	FileName = Name_temp & "_合并.xls"	'合并文件完整名称(含路径)	MergeFile = FilePath & Filename		Do While FileNames <> ""		If FileNames <> ThisWorkbook.Name Then			'打开工作簿			Set FileOpen = Workbooks.Open(Path_Current & Path_Separator & FileNames)			'定义源工作表			Set SheetData = FileOpen.Worksheets(1)			'复制			SheetData.Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)			'用文件名命名sheet名			'ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Replace(Split(FileOpen.Name, ".")(0),Name_temp & "_","")			FileOpen.Close			Num = Num + 1		End If		FileNames = Dir	Loop		'判断需要生成的文件是否存在，如存在，则删除	If Dir(MergeFile) <> "" Then		Kill MergeFile	End If	'另存文件	ActiveWorkbook.SaveAs Filename:=MergeFile, FileFormat:=xlNormal	MsgBox "共合并了 " & Num &" 个文件。" & chr(13) & "存储路径：" & MergeFile & " 。", vbInformation, "提示"	'关闭窗口	ActiveWindow.Close	'启用屏幕刷新	Application.ScreenUpdating = TrueEnd Sub

---