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).AutoFilterElseIfActiveSheet.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表按字段拆分为多个工作薄代码如下：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数据源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.Openprovider=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名拆分为工作表代码如下：PrivateSub分拆工作表()DimshtAsWorksheetDimMyBookAsWorkbookSetMyBook=ActiveWorkbookForEachshtInMyBook.Sheetssht.CopyActiveWorkbook.SaveAsFilename:=MyBook.Path&\&sht.Name,FileFormat:=xlNormal'将工作簿另存为EXCEL默认格式ActiveWorkbook.CloseNextMsgBox文件已经被分拆完毕!EndSub4,、将多个工作薄合并为一个多sheet的工作薄代码如下：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=CombinedSheets(2).ActivateRange(A1).EntireRow.SelectSelection.CopyDestination:=Sheets(1).Range(A1)ForJ=2ToSheets.CountSheets(J).ActivateRange(A1).SelectSelection.CurrentRegion.SelectSelection.Offset(1,0).Resize(Selection.Rows.Count-1).SelectSelection.CopyDestination:=Sheets(1).Range(A65536).End(xlUp)(2)NextEndSub