使用VBA将Excel工作表分割成多个文件
来源:互联网 发布:macbook卸载软件 编辑:程序博客网 时间:2024/05/18 04:29
问题描述
有一个表格,具体数据如下图所示。这里需要按城市(即B列数据)对表格进行拆分,拆分出多个以城市名称命名的xlsx文件,每个xlsx文件都只包含当前城市的数据。
相关资料
之前没有接触过Excel相关的编程,也没有学习过VB语言,完全是摸着石头过河。在这里把期间使用过的一些资料罗列下,方便以后再次用到的时候,可以快速再捡起来。
Excel 2007 VBA Macro Programming
这个是英文版的电子书,当初在皮皮书屋(皮皮书屋是好东西,你懂的)上随便找的,做为我VBA的入门书籍。主要从这本书里学习了VBA的对象模型,几个常用的对象,Application、Workbook、Worksheet、Range。这本书有个好的地方就是在书的后面有个索引,可以快速地查看自己想了解的内容。这本书也有个大的缺陷,就是内容讲得还不够详细具体,往往找到了自己想了解的内容,想深入了解下各种操作,结果发现它讲完了。在线教程
这是个非常好的网站,里面包含了很多简单的例子及代码。当想要实现某个简单地操作的时候,可以先到这里来找找看有没有相应的实例。有一点搞不明白的就是,明明是中文网站,怎么贴的图片里的Excel都是日文的(好吧,不深究了)。对于新手来说非常有用,推荐之。Excel函数在线查询
最权威的Excel函数查询网站,好吧,其实就是微软的MSDN啦。虽然说MSDN的文档有时候的确搞不清楚它在讲什么,但是它还是最详细的。代码
好吧,不废话了,直接上代码。
Sub XXX_Click()
'输入用户想要拆分的工作表
Dim sheet_name
sheet_name = Application.InputBox("请输入拆分工作表的名称:")
Worksheets(sheet_name).Select
'输入获取拆分需要的条件列
Dim col_name
col_name = Application.InputBox("请输入拆分依据的列号(如A):")
'输入拆分的开始行,要求输入的是数字
Dim start_row As Integer
start_row = Application.InputBox(prompt:="请输入拆分的开始行:", Type:=1)
'暂停屏幕更新
Application.ScreenUpdating = False
'工作表的总行数
Dim end_row
end_row = Worksheets(sheet_name).Range("A65536").End(xlUp).Row
'遍历计算所有拆分表,每个拆分表的格式为"表名称,表行数"
'对于二维数组,ReDim只能扩充最后一维,因此sheet_map行不变,扩充列
Dim sheet_map(), sheet_index
ReDim sheet_map(1, 0)
sheet_map(0, 0) = Range(col_name & start_row).Value
sheet_map(1, 0) = 1
sheet_index = 0
With Worksheets(sheet_name)
Dim row_count, temp, i
row_count = 0
For i = start_row + 1 To end_row
temp = Range(col_name & i).Value
If temp = Range(col_name & (i - 1)).Value Then
sheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1
Else
ReDim Preserve sheet_map(1, sheet_index + 1)
sheet_index = sheet_index + 1
sheet_map(0, sheet_index) = temp
sheet_map(1, sheet_index) = 1
End If
Next
End With
'根据前面计算的拆分表,拆分成单个文件
Dim row_index
row_index = start_row
For i = 0 To sheet_index
Workbooks.Add
'创建最终数据文件夹
Dim dir_name
dir_name = ThisWorkbook.Path & "\拆分出的表格\"
If Dir(dir_name, vbDirectory) = "" Then
MkDir (dir_name)
End If
'创建新工作簿
Dim workbook_path
workbook_path = ThisWorkbook.Path & "\拆分出的表格\" & sheet_map(0, i) & ".xlsx"
ActiveWorkbook.SaveAs workbook_path
ActiveSheet.Name = sheet_map(0, i)
'激活当前工作簿,ThisWorkbook表示当前跑代码的工作簿
ThisWorkbook.Activate
'拷贝条目数据(即最前面不需要拆分的数据行)
Dim row_range
row_range = 1 & ":" & (start_row - 1)
Worksheets(sheet_name).Rows(row_range).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A1").PasteSpecial
'拷贝拆分表的专属数据
row_range = row_index & ":" & (row_index + sheet_map(1, i) - 1)
Worksheets(sheet_name).Rows(row_range).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A" & start_row).PasteSpecial
row_index = row_index + sheet_map(1, i)
'保存文件
Workbooks(sheet_map(0, i) & ".xlsx").Close SaveChanges:=True
Next
'进行屏幕更新
Application.ScreenUpdating = True
MsgBox "拆分工作表完成"
End Sub
'输入用户想要拆分的工作表
Dim sheet_name
sheet_name = Application.InputBox("请输入拆分工作表的名称:")
Worksheets(sheet_name).Select
'输入获取拆分需要的条件列
Dim col_name
col_name = Application.InputBox("请输入拆分依据的列号(如A):")
'输入拆分的开始行,要求输入的是数字
Dim start_row As Integer
start_row = Application.InputBox(prompt:="请输入拆分的开始行:", Type:=1)
'暂停屏幕更新
Application.ScreenUpdating = False
'工作表的总行数
Dim end_row
end_row = Worksheets(sheet_name).Range("A65536").End(xlUp).Row
'遍历计算所有拆分表,每个拆分表的格式为"表名称,表行数"
'对于二维数组,ReDim只能扩充最后一维,因此sheet_map行不变,扩充列
Dim sheet_map(), sheet_index
ReDim sheet_map(1, 0)
sheet_map(0, 0) = Range(col_name & start_row).Value
sheet_map(1, 0) = 1
sheet_index = 0
With Worksheets(sheet_name)
Dim row_count, temp, i
row_count = 0
For i = start_row + 1 To end_row
temp = Range(col_name & i).Value
If temp = Range(col_name & (i - 1)).Value Then
sheet_map(1, sheet_index) = sheet_map(1, sheet_index) + 1
Else
ReDim Preserve sheet_map(1, sheet_index + 1)
sheet_index = sheet_index + 1
sheet_map(0, sheet_index) = temp
sheet_map(1, sheet_index) = 1
End If
Next
End With
'根据前面计算的拆分表,拆分成单个文件
Dim row_index
row_index = start_row
For i = 0 To sheet_index
Workbooks.Add
'创建最终数据文件夹
Dim dir_name
dir_name = ThisWorkbook.Path & "\拆分出的表格\"
If Dir(dir_name, vbDirectory) = "" Then
MkDir (dir_name)
End If
'创建新工作簿
Dim workbook_path
workbook_path = ThisWorkbook.Path & "\拆分出的表格\" & sheet_map(0, i) & ".xlsx"
ActiveWorkbook.SaveAs workbook_path
ActiveSheet.Name = sheet_map(0, i)
'激活当前工作簿,ThisWorkbook表示当前跑代码的工作簿
ThisWorkbook.Activate
'拷贝条目数据(即最前面不需要拆分的数据行)
Dim row_range
row_range = 1 & ":" & (start_row - 1)
Worksheets(sheet_name).Rows(row_range).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A1").PasteSpecial
'拷贝拆分表的专属数据
row_range = row_index & ":" & (row_index + sheet_map(1, i) - 1)
Worksheets(sheet_name).Rows(row_range).Copy
Workbooks(sheet_map(0, i) & ".xlsx").Sheets(1).Range("A" & start_row).PasteSpecial
row_index = row_index + sheet_map(1, i)
'保存文件
Workbooks(sheet_map(0, i) & ".xlsx").Close SaveChanges:=True
Next
'进行屏幕更新
Application.ScreenUpdating = True
MsgBox "拆分工作表完成"
End Sub
似乎,博客的代码着色功能不是好呀,看着让人感觉好费力,再给大家上两张看着舒服的图片吧。
0 0
- 使用VBA将Excel工作表分割成多个文件
- Excel中用VBA将根据列内容分割成多个工作表
- 使用 Excel 2003 工作表的 VBA 示例
- 使用 Excel 2003 工作表的 VBA 示例
- 使用 Excel 2003 工作表的 VBA 示例 (From MSDN)
- 【excel VBA】中英文分割
- Excel中使用VBA筛选数据并将结果另存为新的EXCEL文件
- Excel VBA高效办公应用-第十六章-VBA高效文件操作(使用级联菜单管理多个工作簿)
- 【VBA研究】如何将Excel工作表的内容更新到数据库
- 通过VBA宏合并Excel工作表
- VBA EXCEL 对象操作 - 新建工作表
- 【VBA研究】统计Excel 工作表数量
- Excel VBA 将当前活动工作表中的图片保存到以工作表名称命名的文件夹内
- 使用VBA合并多个Excel文件
- VBA实现保存Excel多个工作表中的选择区域为CSV文件
- Excel VBA实用代码1:判断工作表是否存在,文件是否存在[20110227]
- Excel VBA-批量将多个sheet表另存为单独的工作薄文件
- 关于Excel下通过VBA实现工作簿文件下工作表的合并
- 正则表达式入门
- iOS 多线程的解决方案
- 基于JDK动态代理和CGLIB动态代理的实现Spring注解管理事务(@Trasactional)到底有什么区别
- 第八章:拦截器——深入浅出学Spring Web MVC
- 3-C++学习中的小笔记
- 使用VBA将Excel工作表分割成多个文件
- 常用接口定义02——DB与DR系列端口
- 访问系统相册
- 虚拟视点图像生成011
- 第九章:对Ajax的支持——深入浅出学Spring Web MVC
- 应用Druid进行数据源、SQL、Web应用、URI、Session等监控的简单实现
- keepalive + Nginx实现高可用性及负载均衡
- 升级python到2.7 安装setuptoolos mysqldb
- 第十章:文件上传下载——深入浅出学Spring Web MVC