VBA 编程常见实例

1、1、 将excel汇总好的表，按字段拆分为多sheet的情况：如下图：代码如下：Sub cfs()Dim GSArr() As String '公司名称清单Dim Rca As Integer 'A列数据行数Dim i As IntegerDim Sn As StringSn = ActiveSheet.NameRca = Columns("A:A").End(xlDown).Row 按第A列数据拆分，且第一行无合并单元格ReDim GSArr(1 To 1)GSArr(1) = Cells(2, 1)For i = 3 To Rca If IsError(

2、Application.Match(Cells(i, 1), GSArr, 0) Then ReDim Preserve GSArr(1 To UBound(GSArr) + 1) GSArr(UBound(GSArr) = Cells(i, 1) End IfNextIf ActiveSheet.AutoFilterMode = False Then Rows("1:1").AutoFilterElse If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllDataEnd IfFor i = 1 To UBoun

3、d(GSArr) ActiveSheet.Cells.AutoFilter Field:=1, Criteria1:=GSArr(i) Sheets.Add After:=Sheets(Sheets.Count) ActiveSheet.Name = GSArr(i) Sheets(Sn).Cells.Copy ActiveSheet.Cells Sheets(Sn).ActivateNextEnd Sub2、 将汇总的好的EXCEL表按字段拆分为多个工作薄代码如下：Sub CFGZB() Dim myRange As Variant Dim myArray Dim titleRange As

4、 Range Dim title As String Dim columnNum As Integer myRange = Application.InputBox(prompt:="请选择标题行：", Type:=8) myArray = WorksheetFunction.Transpose(myRange) Set titleRange = Application.InputBox(prompt:="请选择拆分的表头，必须是第一行，且为一个单元格，如：“姓名”", Type:=8) title = titleRange.Value columnNu

5、m = titleRange.Column Application.ScreenUpdating = False Application.DisplayAlerts = False Dim i&, Myr&, Arr, num& Dim d, k For i = Sheets.Count To 1 Step -1 If Sheets(i).Name <> "数据源" Then 待拆分的表sheet名为：数据源 Sheets(i).Delete End If Next i Set d = CreateObject("Scripti

6、ng.Dictionary") Myr = Worksheets("数据源 Arr = Worksheets("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum) For i = 1 To UBound(Arr) d(Arr(i, 1) = "" Next k = d.keys For i = 0 To UBound(k) Set conn = CreateObject("adodb.connection") conn.Open "provider

7、=microsoft.ace.oledb.12.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName 2013版连接字符 Sql = "select * from 数据源$ where " & title & " = '" & k(i) & "'" Dim Nowbook As Workbook Set Nowbook = Workbooks.Add With Nowbook With

8、 .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 With End With ThisWorkbook.Activate Sheets(1).Cells.Select Selection.Copy Workbooks(Nowbook.Name).Activate Selection.PasteSpecial Paste:=xl

9、PasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False Application.CutCopyMode = False Nowbook.SaveAs ThisWorkbook.Path & "" & k(i) Nowbook.Close True Set Nowbook = Nothing Next i conn.Close Set conn = Nothing Application.DisplayAlerts = True Application.ScreenUpdat

10、ing = TrueEnd Sub3、 将含有多sheet的一个工作表，按sheet名拆分为工作表代码如下：Private Sub 分拆工作表() Dim sht As Worksheet Dim MyBook As Workbook Set MyBook = ActiveWorkbook For Each sht In MyBook.Sheets sht.Copy ActiveWorkbook.SaveAs Filename:=MyBook.Path & "" & sht.Name, FileFormat:=xlNormal '将工作簿另存为EXC

11、EL默认格式 ActiveWorkbook.Close Next MsgBox "文件已经被分拆完毕!" End Sub4,、将多个工作薄合并为一个多sheet的工作薄代码如下：Sub Books2Sheets() '定义对话框变量 Dim fd As FileDialog Set fd=Application.FileDialog(msoFileDialogFilePicker) '新建一个工作簿 Dim newwb As Workbook Set newwb=Workbooks.Add With fdIf.Show=-1 Then '定义单个文件

12、变量Dim vrtSelectedItem As Variant'定义循环量 Dim i As Integer i=1 '开始文件检索 For Each vrtSelectedItem In.SelectedItems '打开被合并工作簿 Dim tempwb As Workbook Set tempwb=Workbooks.Open(vrtSelectedItem) '复制工作表 tempwb.Worksheets(1).Copy Before:=newwb.Worksheets(i)'把新工作簿的工作表名字改成被复制工作簿文件名，这儿应用于xls文件

13、，即Excel97-2003的文件， 如果是Excel2007，需要改成xlsxnewwb.Worksheets(i).Name=VBA.Replace(tempwb.Name,".xls","")'关闭被合并工作簿tempwb.Close SaveChanges:=Falsei=i+1Next vrtSelectedItemEnd IfEnd With Set 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