自动按列分组拆分excel工作表.doc

自动按列分组拆分excel工作表可以将一个excel工作表按照指定列分组拆分成多个工作表，甚至可以将已经拆分的多个工作表再次拆分成单独的excel文件。略懂一些编程语言的可以将代码改编，以达到批量拆分多个工作表，或者批量合并多个excel文件、工作表，有了vbs的支持，只要你想的到就能做的到！拷贝代码时请注意自动换行格式。自动拆分工作表自动创建文件夹自动保存单独的excel文件至文件夹自动过滤空行，如果存在大量集中的空行请尽量删除空行，因为大量空行会影响运行效率使用方法：打开待拆分的excel文档，按ALT+F11进入vba模式，鼠标选【插入】-【模块】，在右侧新建的模块内将准备好的代码粘贴进去，然后按F5，直接运行。此时会让你选择标题行和待分组的列标题。选完确定开始自动拆分，此时鼠标会不停闪动，根据文档大小，运行一段时间，并不是死机，一般会有几分钟时间，如果你的文档有上万行那会更久。你只需关注文档所在目录是否已经自动创建文件夹并创建excel文件。vbs代码开始Sub CFGZB() Dim myRange As Variant Dim myArray Dim titleRange As Range Dim title As String Dim ShName As String Dim columnNum As Integer myRange = Application.InputBox(prompt:=请选择标题行：, Type:=8) myArray = WorksheetFunction.Transpose(myRange) Set titleRange = Application.InputBox(prompt:=请选择拆分的表头，必须是第一行，且为一个单元格，如：姓名, Type:=8) title = titleRange.Value columnNum = titleRange.Column Application.Volatile ShName = ActiveSheet.Name Application.ScreenUpdating = False Application.DisplayAlerts = False Dim i&, Myr&, Arr, num& Dim d, k For i = Sheets.Count To 1 Step -1 If Sheets(i).Name ShName Then Sheets(i).Delete End If Next i Set d = CreateObject(Scripting.Dictionary) Myr = Worksheets(ShName).UsedRange.Rows.Count Arr = Worksheets(ShName).Range(Cells(2, columnNum), Cells(Myr, columnNum) For i = 1 To UBound(Arr) d(Arr(i, 1) = Next k = d.keys For i = 0 To UBound(k) If k(i) Then Set conn = CreateObject(adodb.connection) conn.Open provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source= & ThisWorkbook.FullName Sql = select * from & ShName & $ where & title & = & k(i) & Worksheets.Add after:=Sheets(Sheets.Count) With ActiveSheet .Name = k(i) For num = 1 To UBound(myArray) .Cells(1, num) = myArray(num, 1) Next num .Range(A2).CopyFromRecordset conn.Execute(Sql) End With Sheets(1).Select Sheets(1).Cells.Select Selection.Copy Worksheets(Sheets.Count).Activate ActiveSheet.Cells.Select Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False End If Next i conn.Close Set conn = Nothing Application.DisplayAlerts = TrueApplication.ScreenUpdating = True拆分至工作表完毕，开始拆分至单独文件，如无需拆分至文件，请将以下代码删除，保留最后一行End Sub结束语 Dim sht As Worksheet Dim MyBook As Workbook Set MyBook = ActiveWorkbook Set fso = CreateObject(scripting.filesystemobject) fso.createfolder (MyBook.Path & & ShName) For Each sht In MyBook.Sheets If sht.Name ShName Then sht.Copy ActiveWorkbook.SaveAs Filena