資源描述：
《VBA 編程常見實例.doc》由會員上傳分享，免費在線閱讀，更多相關內容在行業(yè)資料-天天文庫。
1、1、將excel匯總好的表，按字段拆分為多sheet的情況：如下圖：代碼如下：Subcfs()DimGSArr()AsString'公司名稱清單DimRcaAsInteger'A列數(shù)據行數(shù)DimiAsIntegerDimSnAsStringSn=ActiveSheet.NameRca=Columns("A:A").End(xlDown).Row‘按第A列數(shù)據拆分，且第一行無合并單元格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<>"數(shù)據源"Then‘待拆分的表sheet名為：數(shù)據源Sheets(i).DeleteEndIfNextiSetd=
6、CreateObject("Scripting.Dictionary")Myr=Worksheets("數(shù)據源").UsedRange.Rows.CountArr=Worksheets("數(shù)據源").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[數(shù)據源$]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
