VBA 编程常见实例

1、将excel汇总好的表，按字段拆分为多sheet的情况：如下图：代码如下：Sub cfs()Dim Rca As Integer 'A列数据行数Dim i As IntegerDim Sn As StringSn = Rca = Columns("A:A").End(xlDown).Row ‘按第A列数据拆分，且第一行无合并单元格ReDim GSArr(1 To 1)GSArr(1) = Cells(2, 1)For i = 3 To RcaIf IsError(Application.Match(Cells(i, 1), GSArr, 0)) ThenReDim Preserve GSArr(1 To UBound(GSArr) + 1)GSArr(UBound(GSArr)) = Cells(i, 1)End IfNextIf ActiveSheet.AutoFilterMode = False ThenRows("1:1").AutoFilterElseIf ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllDataEnd IfFor i = 1 To UBound(GSArr)ActiveSheet.Cells.AutoFilter Field:=1, Criteria1:=GSArr(i)Sheets.Add After:=Sheets(Sheets.Count) = GSArr(i)Sheets(Sn).Cells.Copy ActiveSheet.CellsSheets(Sn).ActivateNextActiveSheet.Cells.AutoFilterEnd Sub2、将汇总的好的EXCEL表按字段拆分为多个工作薄代码如下：Sub CFGZB()Dim myRange As VariantDim myArrayDim titleRange As RangeDim title As StringDim columnNum As IntegermyRange = Application.InputBox(prompt:="请选择标题行：", Type:=8)myArray = WorksheetFunction.Transpose(myRange)Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", Type:=8)title = titleRange.ValuecolumnNum = titleRange.ColumnApplication.ScreenUpdating = FalseApplication.DisplayAlerts = FalseDim i&, Myr&, Arr, num&Dim d, kFor i = Sheets.Count To 1 Step -1If Sheets(i).Name <> "数据源" Then ‘待拆分的表sheet名为：数据源eXYo3 Sheets(i).DeleteEnd IfNext iSet d = CreateObject("Scripting.Dictionary")Myr = Worksheets("数据源").UsedRange.Rows.CountArr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum))For i = 1 To UBound(Arr)d(Arr(i, 1)) = ""Nextk = d.keysFor i = 0 To UBound(k)Set conn = CreateObject("adodb.connection")conn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 8.0;datasource=" & ThisWorkbook.FullName ‘2013版连接字符dxIGiSql = "select * from [数据源$] where " & title & " = '" & k(i) & "'"Dim Nowbook As WorkbookSet Nowbook = Workbooks.AddWith NowbookWith .Sheets(1).Name = k(i)For num = 1 To UBound(myArray).Cells(1, num) = myArray(num, 1)Next num.Range("A2").CopyFromRecordset conn.Execute(Sql)End WithEnd WithThisWorkbook.ActivateSheets(1).Cells.SelectSelection.CopyWorkbooks().ActivateActiveSheet.Cells.SelectSelection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _SkipBlanks:=False, Transpose:=False Application.CutCopyMode = FalseNowbook.SaveAs ThisWorkbook.Path & "\" & k(i)Nowbook.Close TrueSet Nowbook = NothingNext iconn.CloseSet conn = NothingApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueEnd Sub3、将含有多sheet的一个工作表，按sheet名拆分为工作表代码如下：Private Sub 分拆工作表()Dim sht As WorksheetDim MyBook As WorkbookSet MyBook = ActiveWorkbookFor Each sht In MyBook.Sheetssht.CopyActiveWorkbook.SaveAs & "\" & , '将工作簿另存为EXCEL默认格式ActiveWorkbook.CloseNextMsgBox "文件已经被分拆完毕!"End Sub4,、将多个工作薄合并为一个多sheet的工作薄代码如下：Sub Books2Sheets()'定义对话框变量Dim fd AsSet fd=Application.(mso)'新建一个工作簿Dim newwb As WorkbookSet newwb=Workbooks.AddWith fdIf.Show=-1 Then'定义单个文件变量Dim vrtSelectedItem As Variant'定义循环量Dim i As Integeri=1'开始文件检索For Each vrtSelectedItem In.SelectedItems'打开被合并工作簿Dim tempwb As WorkbookSet tempwb=Workbooks.Open(vrtSelectedItem)'复制工作表tempwb.Worksheets(1).Copy Before:=newwb.Worksheets(i)'把新工作簿的工作表名字改成被复制工作簿文件名，这儿应用于xls文件，即Excel97-2003的文件，如果是Excel2007，需要改成xlsxnewwb.Worksheets(i).Name=VBA.Replace(,".xls","")'关闭被合并工作簿tempwb.Close SaveChanges:=Falsei=i+1Next vrtSelectedItemEnd IfEnd WithSet fd=NothingEnd Sub5、将含有多个sheet的工作表内容信息汇总至一个sheet中Sub Combine()Dim J As IntegerOn Error Resume NextSheets(1).SelectWorksheets.AddSheets(1).Name = "Combined"Sheets(2).ActivateRange("A1").EntireRow.SelectSelection.Copy Destination:=Sheets(1).Range("A1")For J = 2 To Sheets.CountSheets(J).ActivateRange("A1").SelectSelection.CurrentRegion.SelectSelection.Offset(1, 0).Resize(Selection.Rows.Count - 1).SelectSelection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2)NextEnd Sub。