保留表头拆分数据为若干新工作簿

cccccc7788

大神们，我是想写保留前5行，按列拆分数据为若干新工作簿，但是代码一直错了，可以帮忙 看一下吗？


Sub 保留表头拆分数据为若干新工作簿()
    Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
    c = Application.InputBox("请输入拆分列号", , 6, , , , , 1)
    If c = 0 Then Exit Sub
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    arr = [a1].CurrentRegion
    lc = UBound(arr, 2)
    Set rng = [a1].Resize(5, 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(5, 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

liulang0808

报错的时候，如果有调试，楼主选择调试，看看报错位置行代码具体参数情况
如果还有问题，请上传附件

感觉这个地方不太合适，楼主对应附件看看把
    For i = 2 To UBound(arr)
         If Not d.Exists(arr(i, c)) Then
            Set d(arr(i, c)) = Cells(i, 1).Resize(5, lc)
        Else
            Set d(arr(i, c)) = Union(d(arr(i, c)), Cells(i, 1).Resize(1, lc))
        End If
    Next

cccccc7788

liulang0808 发表于 2020-4-4 20:00
报错的时候，如果有调试，楼主选择调试，看看报错位置行代码具体参数情况
如果还有问题，请上传附件

还是不行啊，麻烦再帮忙 看一下大神，谢谢啊！

liulang0808

楼主参考看看把

cccccc7788

liulang0808 发表于 2020-4-4 20:24
楼主参考看看把

还是不行啊，只有一行表头了，我想保留5行表头，而且按钮也带过去了

grf1973

Sub 保留表头拆分数据为若干新工作簿()
     Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
     c = Application.InputBox("请输入拆分列号", , 6, , , , , 1)
     If c = 0 Then Exit Sub
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     arr = ActiveSheet.UsedRange
     lc = UBound(arr, 2)
     Set rng = [a1].Resize(5, lc)
     Set d = CreateObject("scripting.dictionary")
     For i = 6 To UBound(arr)
        If Len(arr(i, c)) > 0 Then
             If Not d.Exists(arr(i, c)) Then
                Set d(arr(i, c)) = Union(rng, 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
        End If
     Next
     For Each x In d.keys
        With Workbooks.Add(xlWBATWorksheet)
             d(x).Copy .Sheets(1).[a1]
             .SaveAs Filename:=ThisWorkbook.Path & "\" & x & ".xls"
             .Close
         End With
     Next
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
     MsgBox "完毕"
End Sub

liulang0808

Sub 保留表头拆分数据为若干新工作簿()
     Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
     c = Application.InputBox("请输入拆分列号", , 6, , , , , 1)
     If c = 0 Then Exit Sub
     Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     arr = ActiveSheet.UsedRange
     lc = UBound(arr, 2)
     Set rng = [a1].Resize(5, lc)
     rng.Select
     Set d = CreateObject("scripting.dictionary")
     For i = 6 To UBound(arr)
        If Len(arr(i, c)) > 0 Then
          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
         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).[a6]
             For Each shp In .Sheets(1).Shapes
                shp.Delete
             Next shp
             .SaveAs Filename:=ThisWorkbook.Path & "\" & k(i) & ".xls"
             .Close
         End With
     Next
     Application.DisplayAlerts = True
     Application.ScreenUpdating = True
     MsgBox "完毕"
End Sub

liulang0808

附件内容供参考。。。。。。

cccccc7788

liulang0808 发表于 2020-4-4 20:43
附件内容供参考。。。。。。

可以了，太感谢大神

xiexl

1. Sub splilt_sheet()
   
2. Dim i%, irow%, icol%, split_col, aa, arr
   
3. Dim sht0 As Worksheet, sht As Worksheet
   
4. Dim d As Object, wb As Workbook
   
5. Set wb = ActiveWorkbook
   
6. Set sht0 = ActiveSheet
   
7. Set d = CreateObject("scripting.dictionary")
   
8. split_col = InputBox("请输入拆分的列数。例：(1,2,3……或a,b,c……)", , 6)
   
9. If Not IsNumeric(split_col) Or split_col < 0 Then
   
10.     split_col = Application.Match(split_col, Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j"), 0)
    
11.     If Application.IsNA(split_col) Then
    
12.         MsgBox "请正确输入拆分的列数。例：(1,2,3……或a,b,c……)"
    
13.         Exit Sub
    
14.     End If
    
15. End If
    
16. With sht0
    
17.     irow = .Cells(.Rows.Count, 1).End(xlUp).Row
    
18.     icol = .Cells(5, Columns.Count).End(xlToLeft).Column
    
19.     arr = .Range("a6:a" & irow).Offset(0, split_col - 1)
    
20.     For i = 1 To UBound(arr)
    
21.         If Not IsEmpty(arr(i, 1)) Then
    
22.             d(arr(i, 1)) = ""
    
23.         Else
    
24.             MsgBox "您要拆分的列有空白格，拆分后请人工核对对应数据"
    
25.         End If
    
26.     Next
    
27.     Application.DisplayAlerts = False
    
28.     On Error Resume Next
    
29.     For Each aa In d.keys
    
30.         If aa <> .Name Then
    
31.             Set sht = Sheets(aa)
    
32.             If Err Then
    
33.                 Set sht = Sheets.Add(after:=Sheets(Sheets.Count))
    
34.                 sht.Name = aa
    
35.             End If
    
36.             .Range("a5:z" & icol).AutoFilter field:=split_col, Criteria1:=sht.Name
    
37.             .Range("a1").Resize(irow, icol).Copy sht.Range("a1")
    
38.             sht.Columns("a:ac").AutoFit
    
39.             sht.Copy
    
40.             ActiveWorkbook.SaveAs Filename:=wb.Path & "" & aa & ".xlsx"
    
41.             ActiveWorkbook.Close
    
42.         End If
    
43.     Next
    
44.     On Error GoTo 0
    
45.     .Range("a1").AutoFilter
    
46.     .Select
    
47. End With
    
48. MsgBox "数据处理完毕"
    
49. Application.DisplayAlerts = ture
    
50. End Sub

复制代码