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

自动按列分组拆分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