根据某列字段拆分多个工作簿

熊宝宝学excel

这是之前版主写的代码  我想问如何保留前7行为表头怎么改楠？
Sub 保留表头拆分数据为若干新工作簿()
    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
    c = Application.InputBox("请输入拆分列号", , 4, , , , , 1)
    If c = 0 Then Exit Sub
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = [a1].CurrentRegion
    lc = UBound(arr, 2)
    Set rng = [a1].Resize(, lc)
    Set d = CreateObject("scripting.dictionary")
    For i = 2 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
    For i = 0 To d.Count - 1
        With Workbooks.Add(xlWBATWorksheet)
            rng.Copy .Sheets(1).[a1]
            t(i).Copy .Sheets(1).[a2]
            .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"
            .Close
        End With
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

jiminyanyan

上个附件吧。。。。。。

小花鹿

代码写的好....................................................................................................

棋行天下黄

On Error Resume Next

Dim wb As Workbook, arr, rng As Range, d As Object, K, t, sh As Worksheet, i&, J As Integer, STR As String
    Set rng = Range(Cells(1, 1), Cells(1, Columns.Count).End(xlToLeft))
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
   STR = InputBox("请输入分拆后的文件名")
    J = InputBox("请输入关键名称在第几列?请输入数字")
    arr = Range(Cells(1, J), Cells(Rows.Count, J).End(xlUp))
    Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(arr)
        If Not d.Exists(arr(i, 1)) Then
            Set d(arr(i, 1)) = Cells(i, 1).Resize(1, Columns.Count)
        Else
            Set d(arr(i, 1)) = Union(d(arr(i, 1)), Cells(i, 1).Resize(1, Columns.Count))
        End If
    Next
    K = d.Keys
    t = d.Items
    For i = 0 To d.Count - 1
        Set wb = Workbooks.Add(xlWBATWorksheet)
        With wb.Sheets(1)
            rng.Copy .[A1]
            t(i).Copy .[A2]
        End With
        wb.SaveAs Filename:=ThisWorkbook.Path & "\" & STR & K(i) & ".xlsx"
        wb.Close
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "表已分拆完毕，拆分后的文件在文件夹中查找"

乐乐2006201505

Sub 保留表头拆分数据为若干新工作簿()
    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
    c = Application.InputBox("请输入拆分列号", , 4, , , , , 1)
    If c = 0 Then Exit Sub
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = [a1].CurrentRegion
    lc = UBound(arr, 2)
    Set rng = [a1].Resize(6, lc)                                  '本句代码中，偏移行的多少决定保留表头的行数，你要保留7行，就可以将6改为7即可。
    Set d = CreateObject("scripting.dictionary")
    For i = 2 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
    For i = 0 To d.Count - 1
        With Workbooks.Add(xlWBATWorksheet)
            rng.Copy .Sheets(1).[a1]
            t(i).Copy .Sheets(1).[a7]                         '这句中A列数字为几，则拆分后的数据在A列第几行，需要比前面红色注明的数字大1。
            .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"
            .Close
        End With
    Next
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "完毕"
End Sub

经过上边两步，就可以实现表头留随意几行，你可以试试。希望对你有用，而且希望回答的不是太迟。如果解决了你的问题，请告诉一声。谢谢！

南极烤熊

乐乐2006201505 发表于 2016-12-5 20:51
Sub 保留表头拆分数据为若干新工作簿()
    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
    ...

感谢，又学习了，还有，如果我想粘贴到新工作薄的内容是转置粘贴的，怎么实现啊

乐乐2006201505

南极烤熊 发表于 2017-1-18 09:29
感谢，又学习了，还有，如果我想粘贴到新工作薄的内容是转置粘贴的，怎么实现啊

传附件，说明要求。

Jennifer1710221

乐乐2006201505 发表于 2016-12-5 20:51
Sub 保留表头拆分数据为若干新工作簿()
    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
    ...

你好，如果我需要在拆分后的表格中，都需要按照某种格式来保存，例如都需要把字体变为宋体，把某一列的颜色变为黄色，那么应该在程序中的什么地方修改一下呢？万分感谢！

hahaha123111

@乐乐2006201505 老师，如果将代码改为在该文件中生成多个子表，改动是不是很方便？

hahaha123111

乐乐2006201505 发表于 2016-12-5 20:51
Sub 保留表头拆分数据为若干新工作簿()
    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
    ...

@乐乐2006201505 老师，如果将代码改为在该文件中生成多个子表，改动是不是很方便？