用VBA把一个工作表跟据表头关键字分成多个工作簿

发布网友 发布时间：2022-04-23 00:57

我来回答

共4个回答

热心网友 时间：2023-10-09 15:54

插入模块，然后复制粘贴如下代码：

Public Sub 按姓名拆分成多个工作簿()
'此宏使用方法:先激活需要拆分的工作表，然后调用本宏命令
Dim MyBook As Workbook, BK As Workbook, MySht As Worksheet, Rng As Range, rng1 As Range, rng2 As Range, rng3 As Range
Set MyBook = ThisWorkbook
Set MySht = ActiveSheet
Set Rng = Application.Intersect(MySht.UsedRange, [B2:IV2]) '姓名行
Set rng1 = Application.Intersect(MySht.UsedRange, [A3:A10000]) '月份列
For Each rng2 In Rng
    Set BK = Workbooks.Add()
    Set rng3 = Application.Intersect(MySht.UsedRange, MySht.Range(rng2.Offset(1, 0), rng2.Offset(99999, 0)))
    rng1.Copy
    BK.Activate
    BK.Sheets(1).Activate
    [A1].Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    rng3.Copy
    [A2].Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True
    BK.SaveAs Filename:=rng2.Value
    BK.Close
Next
End Sub

热心网友 时间：2023-10-09 15:54

既然不追问，则直接贴代码吧

1
2
3
4
5
6
7
8
9
10

Sub 工作簿拆分()
Dim wb As Workbook, sh As Worksheet
For Each sh In Worksheets '遍历所有工作表
sh.Copy '复制工作表
Set wb = ActiveWorkbook '到新的工作簿
k = k + 1 '计数 '注：此行也可写成k=sh.name 如果这样写，则下行中汉字去掉。
wb.SaveAs ThisWorkbook.Path & "/第" & k & "个表.xls" '在本文件路径中保存工作簿
wb.Close '关闭创建的工作簿
Next

热心网友 时间：2023-10-09 15:55

关注微信公众号”Excel大表姐”，回复“拆表”两字，获取万能拆表模板，只要把要拆分的表格放进去就行了

热心网友 时间：2023-10-09 15:56

这个比较简单。请提供下样表，谢谢