拆分代码

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)-1Setconn=CreateObject(adodb.connection)conn.Openprovider=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