VBA编程常见实例

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(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省财务共享服务口心201679/1214:57MicrosoftExcel...C武汉分公司2016/9/1214:57MicrosoftExcel...1;匾密诊一2016/9/1214:4-0MicrosoftExcel...空时者网金熟2016/9/12141&MicrosoftExcel...ET省公司网发部201679/1214:1&MicrosoftExcel...正省公司网运部2016/9/121416MicrosoftExcel...IEET省号百公司201679/1214116IVlicr&EoftExce-I...式ET值惜值中心2016/9/1214:15MicrosoftExcel...IECT省终局中心2016/9/1214:16MicrosoftExcel...代码如下：SubCFGZB()DimmyRangeAsVariantDimmyArrayDimtitleRangeAsRangeDimtitleAsStringDimcolumnNumAsIntegermyRange=Application.InputBox(prompt:="请选择标题行：",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<>"数据源"Then '待拆分的表sheet名为：数据源Sheets(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.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(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默认格式ActiveWorkbook.CloseNextMsgBox”文件已经被分拆完毕!”EndSub4,、将多个工作薄合并为一个多sheet的工作薄国二〕Hgdx_Excel(l)igdx_Excel(Z)^^1zgdk_Excel(3)团三〕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’定义循环量DimiAsIntegeri=1’开始文件检索ForEachvrtSelectedItemIn.SelectedItems’打开被合并工作簿DimtempwbAsWorkbookSettempwb=Workbooks.Open(vrtSelectedItem)’复制工作表tempwb.Worksheets(1).CopyBefore:=newwb.Worksheets(i)’把新工作簿的工作表名字改成被复制工作簿文件名，这儿应用于xls文件，即Excel97-2003的文件，如果是Excel2007，需要改成xlsxnewwb.Worksheets(i).Name=VBA.Replace(tempwb.Name,".xls","")‘关闭被合并工作簿tempwb.CloseSaveChanges:=Falsei=i+1NextvrtSelectedItemEndIfEndWithSetfd=NothingEndSub5、将含有多个sheet的工作表内容信息汇总至一个sheet中SubCombine()DimJAsIntegerOnErrorResumeNextSheets(1).SelectWorksheets.AddSheets(1).Name="Combined"Sheets(2).ActivateRange("A1").EntireRow.SelectSelection.CopyDestination:=Sheets(1).