VBA編程常見實(shí)例

1、將excel匯總好的表，按字段拆分為多sheet的情況：如下圖:匚總武波分公司黃岡分公司襄陽分公司削州分公司宜昌分公司孝領(lǐng)公司十堰分公司代碼如下：Subcfs()DimGSArr()AsString'公司名稱清單DimRcaAsInteger'A列數(shù)據(jù)行數(shù)DimiAsIntegerDimSnAsStringSn=ActiveSheet.NameRca=Columns("A:A").End(xlDown).Row ,按第A列數(shù)據(jù)拆分，且第一行無合并單元格ReDimGSArr(1To1)GSArr(1)=Cells(2,1)Fori=3ToRcaIfIsError(Application.Match(Cells(i,1),GSArr,0))ThenReDimPreserveGSArr(1ToUBound(GSArr)+1)GSArr(UBound(GSArr))=Cells(i,1)EndIfNextIfActiveSheet.AutoFilterMode=FalseThenRows("1:1").AutoFilter日seIfActiveSheet.FilterMode=TrueThenActiveSheet.ShowAllDataEndIfFori=1ToUBound(GSArr)ActiveSheet.Cells.AutoFilterField:=1,Criteria1:=GSArr(i)Sheets.AddAfter:=Sheets(Sheets.Count)ActiveSheet.Name=GSArr(i)Sheets(Sn).Cells.CopyActiveSheet.CellsSheets(Sn).ActivateNextActiveSheet.Cells.AutoFilterEndSub2、將匯總的好的EXCEL表按字段拆分為多個工作薄tr省財(cái)務(wù)共享服務(wù)口心201679/1214:57MicrosoftExcel...C武漢分公司2016/9/1214:57MicrosoftExcel...1;匾密診一2016/9/1214:4-0MicrosoftExcel...空時(shí)者網(wǎng)金熟2016/9/12141&MicrosoftExcel...ET省公司網(wǎng)發(fā)部201679/1214:1&MicrosoftExcel...正省公司網(wǎng)運(yùn)部2016/9/121416MicrosoftExcel...IEET省號百公司201679/1214116IVlicr&EoftExce-I...式ET值惜值中心2016/9/1214:15MicrosoftExcel...IECT省終局中心2016/9/1214:16MicrosoftExcel...代碼如下：SubCFGZB()DimmyRangeAsVariantDimmyArrayDimtitleRangeAsRangeDimtitleAsStringDimcolumnNumAsIntegermyRange=Application.InputBox(prompt:="請選擇標(biāo)題行：",Type:=8)myArray=WorksheetFunction.Transpose(myRange)SettitleRange=Application.InputBox(prompt:="i請選擇拆分的表頭，必須是第一行，且為一個單元格，如：“姓名””,Type:=8)title=titleRange.ValuecolumnNum=titleRange.ColumnApplication.ScreenUpdating=FalseApplication.DisplayAlerts=FalseDimi&,Myr&,Arr,num&Dimd,kFori=Sheets.CountTo1Step-1IfSheets(i).Name<>"數(shù)據(jù)源"Then '待拆分的表sheet名為：數(shù)據(jù)源Sheets(i).DeleteEndIfNextiSetd=CreateObject("Scripting.Dictionary")Myr=Worksheets("數(shù)據(jù)源").UsedRange.Rows.CountArr=Worksheets("數(shù)據(jù)源").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.ace.oledb.12.0;extendedproperties=excel8.0;datasource="&ThisWorkbook.FullName,2013版連接字符Sql="select*from[數(shù)據(jù)源$]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=TrueEndSub3、將含有多sheet的一個工作表，按sheet名拆分為工作表sheet3SheetlSheets研Sheetl2016^/1211:15MicrosoftExcel...24KE研Sheets2016/9/1^11:15MicrosoftExcel...24KE量sheets2016/9/1211:15MicrosoftExcel...64KE司待拆分201&/9/1215:57Micro&oftExcel...75KB代碼如下：PrivateSub分拆工作表()DimshtAsWorksheetDimMyBookAsWorkbookSetMyBook=ActiveWorkbookForEachshtInMyBook.Sheetssht.CopyActiveWorkbook.SaveAsFilename:=MyBook.Path& "\" &sht.Name,FileFormat:=xlNormal '將工作簿另存為EXCEL默認(rèn)格式ActiveWorkbook.CloseNextMsgBox”文件已經(jīng)被分拆完畢!”EndSub4,、將多個工作薄合并為一個多sheet的工作薄國二〕Hgdx_Excel(l)igdx_Excel(Z)^^1zgdk_Excel(3)團(tuán)三〕ngdx_ExceI(4)國-igdx_Excel(5)egdk_Ekc.cI(&J的三〕sgdx_ExesI(7)^=1igdx_Excel(3)zgdx_Excel(1)|zgdx_￡^el(2jzgdx_Excel(3)|igdx_Excel(4)|zgdx_Excel(5) zgdxExcel(6] …代碼如下：SubBooks2Sheets()’定義對話框變量DimfdAsFileDialogSetfd=Application.FileDialog(msoFileDialogFilePicker)‘新建一個工作簿DimnewwbAsWorkbookSetnewwb=Workbooks.AddWithfdIf.Show=-1Then‘定義單個文件變量DimvrtSelectedItemAsVariant’定義循環(huán)量DimiAsIntegeri=1’開始文件檢索ForEachvrtSelectedItemIn.SelectedItems’打開被合并工作簿DimtempwbAsWorkbookSettempwb=Workbooks.Open(vrtSelectedItem)’復(fù)制工作表tempwb.Worksheets(1).CopyBefore:=newwb.Worksheets(i)’把新工作簿的工作表名字改成被復(fù)制工作簿文件名，這兒應(yīng)用于xls文件，即Excel97-2003的文件，如果是Excel2007，需要改成xlsxnewwb.Worksheets(i).Name=VBA.Replace(tempwb.Name,".xls","")‘關(guān)閉被合并工作簿tempwb.CloseSaveChanges:=Falsei=i+1NextvrtSelectedItemEndIfEndWithSetfd=NothingEndSub5、將含有多個sheet的工作表內(nèi)容信息匯總至一個sheet中SubCombine()DimJAsIntegerOnErrorResumeNextSheets(1).SelectWorksheets.AddSheets(1).Name="Combined"Sheets(2).ActivateRange("A1").EntireRow.SelectSelection.CopyDestination:=Sheets(1).