VBA 编程常见实例.docVIP

o p 将excel汇总好的表，按字段拆分为多sheet的情况：如下图： 代码如下：Sub cfs() Dim GSArr() As String 公司名称清单 Dim Rca As Integer A列数据行数 Dim i As Integer Dim Sn As String Sn = ActiveSheet.Name Rca = Columns(A:A).End(xlDown).Row ‘按第A列数据拆分，且第一行无合并单元格 ReDim GSArr(1 To 1) GSArr(1) = Cells(2, 1) For i = 3 To Rca If IsError(Application.Match(Cells(i, 1), GSArr, 0)) Then ReDim Preserve GSArr(1 To UBound(GSArr) + 1) GSArr(UBound(GSArr)) = Cells(i, 1) End If Next If ActiveSheet.AutoFilterMode = False Then Rows(1:1).AutoFilter Else If ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllData End If For i = 1 To UBound(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).Activate Next ActiveSheet.Cells.AutoFilter End Sub 将汇总的好的EXCEL表按字段拆分为多个工作薄 代码如下： Sub CFGZB() Dim myRange As Variant Dim myArray Dim titleRange As 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 columnNum = 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(Scripting.Dictionary) Myr = Worksheets(数据源).UsedRange.Rows.Count 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=microsoft.ace.oledb.12.0;extended properties=excel 8.0;data source= ThisWork