资源描述：
《VBA 编程常见实例.doc》由会员上传分享，免费在线阅读，更多相关内容在行业资料-天天文库。
1、1、将excel汇总好的表，按字段拆分为多sheet的情况：如下图：代码如下：Subcfs()DimGSArr()AsString'公司名称清单DimRcaAsInteger'A列数据行数DimiAsIntegerDimSnAsStringSn=ActiveSheet.NameRca=Columns("A:A").End(xlDown).Row‘按第A列数据拆分，且第一行无合并单元格ReDimGSArr(1To1)GSArr(1)=Cells(2,1)Fori=3ToRcaIfIsError(Applic
2、ation.Match(Cells(i,1),GSArr,0))ThenReDimPreserveGSArr(1ToUBound(GSArr)+1)GSArr(UBound(GSArr))=Cells(i,1)EndIfNextIfActiveSheet.AutoFilterMode=FalseThenRows("1:1").AutoFilterElseIfActiveSheet.FilterMode=TrueThenActiveSheet.ShowAllDataEndIfFori=1ToUBound(G
3、SArr)ActiveSheet.Cells.AutoFilterField:=1,Criteria1:=GSArr(i)Sheets.AddAfter:=Sheets(Sheets.Count)ActiveSheet.Name=GSArr(i)Sheets(Sn).Cells.CopyActiveSheet.CellsSheets(Sn).ActivateNextActiveSheet.Cells.AutoFilterEndSub1、将汇总的好的EXCEL表按字段拆分为多个工作薄代码如下：SubCFGZ
4、B()DimmyRangeAsVariantDimmyArrayDimtitleRangeAsRangeDimtitleAsStringDimcolumnNumAsIntegermyRange=Application.InputBox(prompt:="请选择标题行：",Type:=8)myArray=WorksheetFunction.Transpose(myRange)SettitleRange=Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格
5、，如：“姓名”",Type:=8)title=titleRange.ValuecolumnNum=titleRange.ColumnApplication.ScreenUpdating=FalseApplication.DisplayAlerts=FalseDimi&,Myr&,Arr,num&Dimd,kFori=Sheets.CountTo1Step-1IfSheets(i).Name<>"数据源"Then‘待拆分的表sheet名为：数据源Sheets(i).DeleteEndIfNextiSetd=
6、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.Op
7、en"provider=microsoft.ace.oledb.12.0;extendedproperties=excel8.0;datasource="&ThisWorkbook.FullName‘2013版连接字符Sql="select*from[数据源$]where"&title&"='"&k(i)&"'"DimNowbookAsWorkbookSetNowbook=Workbooks.AddWithNowbookWith.Sheets(1).Name=k(i)Fornum=1ToUBound(my
8、Array).Cells(1,num)=myArray(num,1)Nextnum.Range("A2").CopyFromRecordsetconn.Execute(Sql)EndWithEndWithThisWorkbook.ActivateSheets(1).Cells.SelectSelection.CopyWorkbooks(Nowbook.Name).ActivateActiveSheet.Cells.Select
