一个excel文件按要求分成excel文件

jamieelmo

根据总文件的K列分拆成多个文件（不是同一文件里多张sheet），K列的内容一样汇总到一个文件，并且该文件按照K列命名
比如说，K列中有一条LKCMBOF的记录，则可以将拆分出一个名为LKCMBOF的excel，里面都是K列为LKCMBOF的记录，如SGSINOF则可以拆分成SGSINOF的excel，里面有5条K列为SGSINOF的记录

jamieelmo

独立的excel与总文件的格式要一样

lsc900707

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), FileFormat:=xlExcel12
             .Close
         End With
     Next
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
     MsgBox "完毕"
End Sub

jamieelmo

lsc900707 发表于 2017-1-7 13:28
Sub 保留表头拆分数据为若干新工作簿()
     Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
   ...

有没有办法在vba中让拆分开的excel列宽保持与总文件的列宽一样

lsc900707

jamieelmo 发表于 2017-1-7 14:15
有没有办法在vba中让拆分开的excel列宽保持与总文件的列宽一样

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).Select
             .Sheets(1).[a2].Select
              Selection.PasteSpecial Paste:=xlPasteColumnWidths
              Selection.PasteSpecial Paste:=xlPasteValues
              Selection.PasteSpecial Paste:=xlPasteFormats
             .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i), FileFormat:=xlExcel12
             .Close
         End With
     Next
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
     MsgBox "完毕"
End Sub

jamieelmo

lsc900707 发表于 2017-1-7 14:27
Sub 保留表头拆分数据为若干新工作簿()
     Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
...

谢谢！
再问一个问题，当我用其他文件测试这个代码时，发现拆分excel的标题行格式并没有与总表的一样，比总文件行高窄了，只能在上传的测试文件保持一致，怎么解决

lsc900707

jamieelmo 发表于 2017-1-7 15:00
谢谢！
再问一个问题，当我用其他文件测试这个代码时，发现拆分excel的标题行格式并没有与总表的一样， ...

行高和列宽很难同时保持一致的。

jamieelmo

lsc900707 发表于 2017-1-7 15:10
行高和列宽很难同时保持一致的。

好的，谢谢

jamieelmo

lsc900707 发表于 2017-1-7 14:27
Sub 保留表头拆分数据为若干新工作簿()
     Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
...

我希望文件名可以改成K列关键词的前两个字母，比如LKCMBOF的改成LK,但是若有前两个字母相同的则改成前五个字母，怎么改

lsc900707

jamieelmo 发表于 2017-1-8 16:56
我希望文件名可以改成K列关键词的前两个字母，比如LKCMBOF的改成LK,但是若有前两个字母相同的则改成前五 ...

将这句： .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i), FileFormat:=xlExcel12改成：
  .SaveAs Filename:=ThisWorkbook.Path & "\" & Left(k(i), 2), FileFormat:=xlExcel12