|
excel拆分
一、前言二、准备员工信息表测试数据三、拆分三（1）：根据所在分公司列拆分为多个sheet操作步骤1. 选中要拆分的sheet,右键单击“查看代码”，如图：2. 插入如下代码：3. 运行，实现拆分为多个sheet（代码插入后，直接关闭当前代码窗口即可，无需保存）
拆分后结果
三（2）：根据“所在分公司”列拆分为多个单独excel文件操作步骤1.插入代码
拆分后结果
四、没有宏菜单，如何打开？
一、前言
作为一名运维工程师，难免会遇到各种数据库数据导出需求。最近遇到要求把导出的员工信息根据分公司分组后拆分为多个sheet工作表或多个单独的excel文件。。刚开始通过oracle数据库层面琢磨了好久，不知道怎么实现（通过where条件可以，可是分公司很多呢），好吧，，能力有限，没有倒腾出来 。于是，咱干脆从excel下手。终于功夫不负有心人，通过网上资料，一顿猛操作后，居然成功了，。特别开心，今天分享给大家，话不多说，开干哈。。。
二、准备员工信息表测试数据
三、拆分
三（1）：根据所在分公司列拆分为多个sheet
操作步骤
1. 选中要拆分的sheet,右键单击“查看代码”，如图：
2. 插入如下代码：
Sub 拆分为多个sheet文件()
Dim d As Object, sht As Worksheet, arr, brr, r, kr, i&, j&, k&, x&
Dim Rng As Range, Rg As Range, tRow&, tCol&, aCol&, pd&
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
Set Rg = Application.InputBox("提示：请选择您要拆分的列", Title:="温馨提示", Type:=8)
tCol = Rg.Column
tRow = Val(Application.InputBox("提示：请您输入表的标题总行数？"))
If tRow = 0 Then MsgBox "输入错误，程序将退出！": Exit Sub
Set Rng = ActiveSheet.UsedRange
arr = Rng
tCol = tCol - Rng.Column + 1
aCol = UBound(arr, 2)
For i = tRow + 1 To UBound(arr)
If Not d.exists(arr(i, tCol)) Then
d(arr(i, tCol)) = i
Else
d(arr(i, tCol)) = d(arr(i, tCol)) & "," & i
End If
Next
For Each sht In Worksheets
If d.exists(sht.Name) Then sht.Delete
Next
kr = d.keys
For i = 0 To UBound(kr)
If kr(i) "" Then
r = Split(d(kr(i)), ",")
ReDim brr(1 To UBound(r) + 1, 1 To aCol)
k = 0
For x = 0 To UBound(r)
k = k + 1
For j = 1 To aCol
brr(k, j) = arr(r(x), j)
Next
Next
With Worksheets.Add(, Sheets(Sheets.Count))
.Name = kr(i)
.[a1].Resize(tRow, aCol) = arr
.[a1].Offset(tRow, 0).Resize(k, aCol) = brr
Rng.Copy
.[a1].PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
.[a1].Select
End With
End If
Next
Sheets(1).Activate
Set d = Nothing
Erase arr: Erase brr
Application.ScreenUpdating = True
Application.DisplayAlerts = True
MsgBox "拆分成功，欧耶。"
End Sub
3. 运行，实现拆分为多个sheet（代码插入后，直接关闭当前代码窗口即可，无需保存）
点击excel菜单栏的开发工具-宏-选中刚才代码函数-点击运行 找不到宏，可见本文章末尾，有添加方法哟  提示请输入要拆分的列，这里我们要拆分所在分公司“这一列，所以选中A2，点击【确定】  这里我做了一个表头行数输入，比如咱们这张表，有两行作为表头，那么在提示：“请您请输入标题总行数“时，我填写的2，点击【确定】后，就开始拆分 
拆分后结果
拆分结果如下图，表示本次拆分已经成功： 
三（2）：根据“所在分公司”列拆分为多个单独excel文件
操作步骤
步骤与 三（1）：根据“所在分公司”列拆分为多个单独sheet文件的一样，这里就不做详细图解 excel右键-查看代码-插入代码-宏-运行。注意：在运行下面代码，提示：“请输入拆分列号”，输入列号即可。 如下图,我们要拆分的是第一列，所有输入1即可： 
1.插入代码
Sub 拆分为多个excel文件()
Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
c = Application.InputBox("提示：请输入要拆分列号", , 3, , , , , 1)
tRow = Application.InputBox("提示：请您输入表的标题总行数？")
If tRow = 0 Then MsgBox "输入错误，程序将退出！": Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
arr = [a1].CurrentRegion
lc = UBound(arr, 2)
Set rng = [a1].Resize(tRow + 1, lc)
Set d = CreateObject("scripting.dictionary")
For i = tRow + 1 To UBound(arr)
If Not d.Exists(arr(i, c)) Then
Set d(arr(i, c)) = Cells(i, 1).Resize(1, lc)
Else
Set d(arr(i, c)) = Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc))
End If
Next
k = d.Keys
t = d.Items
tt = tRow + 1
For i = 0 To d.Count - 1
With Workbooks.Add(xlWBATWorksheet)
rng.Copy .Sheets(1).[a1]
t(i).Copy .Sheets(1).[a4]
.SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"
.Close
End With
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "拆分成功，欧耶"
End Sub
拆分后结果
怎么样，是不是超好用。。哈哈哈哈，还行啦。。其实还有好多小细节想完善，比如 拆分主表 “员工信息-主表”中有一个名为 备注的sheet工作表,拆分成多个分公司excel后，也想每个分公司excel表自动带有一个“备注”的sheet工作表！！！！！目前还没有研究出来，有时间再好好琢磨琢磨，到时候再更新哈，嘿嘿，哪位大神知道的话，也欢迎评论区留言哦》》》》
四、没有宏菜单，如何打开？
excel菜单的文件->选项->自定义功能区->宏，点击添加即可。
|