请帮忙改一下代码

assgh1

以下VBA代码，现需要去掉保留表头，以及能否拆分后将只取第一列和第二列的数据，请高手帮忙，谢谢

Sub 保留表头拆分数据为若干新工作簿()
     Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
     c = Application.InputBox("请输入拆分列号", , 3, , , , , 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)
             .Close
         End With
     Next
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
     MsgBox "完毕"
End Sub

凌空一羽

你表头没有东西啊？这样？？？

lsc900707

拆分后的工作簿依什么命名？

assgh1

lsc900707 发表于 2018-8-3 20:33
拆分后的工作簿依什么命名？

拆分后以册号给工作表命名

lsc900707

assgh1 发表于 2018-8-5 17:35
拆分后以册号给工作表命名

简单的修改就好：