Sub split_sheet()

     '输入用户想要拆分的工作表
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("A990000").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
Dim name_hz As String
name_hz = "-20161220-M.xlsx"
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) & name_hz
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) & name_hz).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) & name_hz).Sheets(1).Range("A" & start_row).PasteSpecial
row_index = row_index + sheet_map(1, i) '保存文件
Workbooks(sheet_map(0, i) & name_hz).Close SaveChanges:=True
Next '进行屏幕更新
Application.ScreenUpdating = True MsgBox "拆分工作表完成" End Sub

将一个工作簿分割成多个工作簿并保存到相同文件夹中

Sub Splitbook()
'Updateby20140612
Dim xPath As String
xPath = Application.ActiveWorkbook.Path
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each xWs In ThisWorkbook.Sheets
xWs.Copy
Application.ActiveWorkbook.SaveAs Filename:=xPath & "\" & xWs.Name & ".xls"
Application.ActiveWorkbook.Close False
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

分割excel sheet的更多相关文章

  1. java分割excel文件可用jxl

    excel导入是经常使用到的功能,如果文件数据量大的话还是建议分割后导入,java常用的API是poi和jxl,我采用的是jxl,那么让我们来看下怎么用jxl来实现分割. 需要在pom中导入jxl的包 ...

  2. [LeetCode] Excel Sheet Column Number 求Excel表列序号

    Related to question Excel Sheet Column Title Given a column title as appear in an Excel sheet, retur ...

  3. [LeetCode] Excel Sheet Column Title 求Excel表列名称

    Given a positive integer, return its corresponding column title as appear in an Excel sheet. For exa ...

  4. Excel Sheet Column Title

    Given a positive integer, return its corresponding column title as appear in an Excel sheet. For exa ...

  5. 【leetcode】Excel Sheet Column Title & Excel Sheet Column Number

    题目描述: Excel Sheet Column Title Given a positive integer, return its corresponding column title as ap ...

  6. ✡ leetcode 171. Excel Sheet Column Number 字母转换为数字 --------- java

    Related to question Excel Sheet Column Title Given a column title as appear in an Excel sheet, retur ...

  7. LeetCode 168. Excel Sheet Column Title

    Given a positive integer, return its corresponding column title as appear in an Excel sheet. -> A ...

  8. 【leetcode】Excel Sheet Column Title

    Excel Sheet Column Title Given a non-zero positive integer, return its corresponding column title as ...

  9. 【leetcode】Excel Sheet Column Title & Excel Sheet Column Number (easy)

    Given a positive integer, return its corresponding column title as appear in an Excel sheet. For exa ...

随机推荐

  1. 封装原生Ajax

    var Chef = { createAjax:function() { var xhr = null; try { //IE系列浏览器 xhr = new ActiveXObject("m ...

  2. 读取Excel数据到Table表中

    方法一: try { List<DBUtility.CommandInfo> list = new List<DBUtility.CommandInfo>(); string ...

  3. Jenkins基础 - 常用配置操作

    1.修改jenkins的根目录,默认地在C:\Users\用户名\.jenkins下(win7) 或C:\Documents and Settings\用户名\.jenkins(xp) 修改步骤: 增 ...

  4. Shell 编程基础之变量和环境变量

    一.变量赋值和引用 Shell 编程中,使用变量无需事先声明,同时变量的命名不惜遵循如下规则: 首个字符必须为字母(a-z,A-Z)或者_ 变量名中间不能有空格,可以使用_连接 不能使用其他表达符号 ...

  5. HTML5属性运用

    HTML5 接触移动端,或专注于支持HTML5浏览器进行前端开发的工作者都不会陌生,这个已经普及很广,对于我专注于PC端开发的人来说,觉得陌生但又觉得很熟悉,大家都知道做PC前端开发为了兼容IE老版本 ...

  6. js中继承的几种用法总结(apply,call,prototype)

    一,js中对象继承 js中有三种继承方式 1.js原型(prototype)实现继承 <SPAN style="BACKGROUND-COLOR: #ffffff">& ...

  7. 【HDU】1848 Fibonacci again and again

    http://acm.hdu.edu.cn/showproblem.php?pid=1848 题意:同nim,3堆,每次取的为fib数,n<=1000 #include <cstdio&g ...

  8. Android --#字XO小游戏

    Layout <?xml version="1.0" encoding="utf-8"?> <LinearLayout xmlns:andro ...

  9. thinkphp遗留问题

    $data = array( 'username' => I('username','','htmlspecialchars'), 'content' => I('content'), ' ...

  10. Tom and paper

    题目链接:http://acm.hdu.edu.cn/showproblem.php?pid=5224 题意: 给出矩形的面积,求出最小的周长. 样例: Sample Input 3 2 7 12   ...