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

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

复制代码

xiexl

表拆分成文件和工作表。

cccccc7788

xiexl 发表于 2020-4-4 21:22
表拆分成文件和工作表。

大神，如果我不需要拆成工作表，是可以删掉一段吗

cccccc7788

xiexl 发表于 2020-4-4 21:21

如果不需要拆成工作表，可以删掉哪一段啊

cccccc7788

xiexl 发表于 2020-4-4 21:22
表拆分成文件和工作表。

如果只需要拆成文件，和设定拆分文件C列的宽度，有可能吗

cccccc7788

grf1973 发表于 2020-4-4 20:38
Sub 保留表头拆分数据为若干新工作簿()
     Dim arr, d As Object, k, t, i&, lc%, rng As Range, c%
   ...

太感谢了!!!!!!!!!!!!!!!!!!!!!!!

熊文来

感觉大家的代码很好。就是看不懂。