excel工作表，按照某列的某个条件，符合不同条件的对应分配到一个新的工作簿中，原表格保留。例如：下表期望把一班二班的各个学生的成绩分开两个工作簿。
工具/原料
excel2007
方法/步骤
1、打开所要拆分的EXCEL表格。
2、按ALt+F11键，弹出如下对话框。
3、点击插入-模块。
4、复制下面源代码：SubCFGZB()DimmyRangeAsVariantDimmyArrayDimtitleRangeAsRangeDimtitleAsStringDimcolumnNumAsIntegermyRange=Application.InputBox(prompt:="请选择标题行：",Type:=8)myArray=WorksheetFunction.Transpose(myRange)SettitleRange=Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”",Type:=8)title=titleRange.ValuecolumnNum=titleRange.ColumnApplication.ScreenUpdating=FalseApplication.DisplayAlerts=FalseDimi&,Myr&,Arr,num&Dimd,kFori=Sheets.CountTo1Step-1IfSheets(i).Name<>"成绩单"ThenSheets(i).DeleteEndIfNextiSetd=CreateObject("Scripting.Dictionary")Myr=Worksheets("成绩单").UsedRange.Rows.CountArr=Worksheets("成绩单").Range(Cells(2,columnNum),Cells(Myr,columnNum))Fori=1ToUBound(Arr)d(Arr(i,1))=""Nextk=d.keysFori=0ToUBound(k)Setconn=CreateObject("adodb.connection")conn.Open"provider=microsoft.jet.oledb.4.0;extendedproperties=excel8.0;datasource="&ThisWorkbook.FullNameSql="select*from[成绩单$]where"&title&"='"&k(i)&"'"DimNowbookAsWorkbookSetNowbook=Workbooks.AddWithNowbookWith.Sheets(1).Name=k(i)Fornum=1ToUBound(myArray).Cells(1,num)=myArray(num,1)Nextnum.Range("A2").CopyFromRecordsetconn.Execute(Sql)EndWithEndWithThisWorkbook.ActivateSheets(1).Cells.SelectSelection.CopyWorkbooks(Nowbook.Name).ActivateActiveSheet.Cells.SelectSelection.PasteSpecialPaste:=xlPasteFormats,Operation:=xlNone,_SkipBlanks:=False,Transpose:=FalseApplication.CutCopyMode=FalseNowbook.SaveAsThisWorkbook.Path&"\"&k(i)Nowbook.CloseTrueSetNowbook=NothingNexticonn.CloseSetconn=NothingApplication.DisplayAlerts=TrueApplication.ScreenUpdating=TrueEndSub然后CTRAL+F键，点击替换，查找内容为“成绩单”，替换为文件sheet表的命名，例如我的sheet表命名为成绩单，点全部替换。
5、点击运行-运行子过程/用户窗体。
6、在弹出的窗口里选择，条件所在行，点确定。
7、在弹出的对话框中，点选筛选条件，点确定
8、完成工作任务。
