VBA编程常见实例

1、1、将excel汇总好的表,按字段拆分为多sheet的情况：如下列图:武汶分公言1黄冈分公司襄E日分公司创阴分公司宜昌分公司孝博分公司十堰分公司代码如下：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,

2、 1)For i = 3 To RcaIf IsError(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 ThenRows("1:1").AutoFilterElseIf ActiveSheet.FilterMode = True Then ActiveSheet.ShowAllD

3、ataEnd IfFor 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.CellsSheets(Sn).ActivateNextActiveSheet.Cells.AutoFilterEnd Sub2、将汇总的好的EXCELS按字段拆分为多个工作薄0首叮翁共享I胳口心 肥盒双分公司年省网

4、瘾能O耆公司网发解 Q省公司网运手 口菖号百公司Q -瑁瑁值日心Q省终其口心2022/9/12 14:572022/9/12 14; 572022/9/12 14胸2022/9/12 14162022/5/12 1416202279/12 14:162022；9/12 14162022/9/12 14:16202279/12 1416Microsoft Exce Microsoft Exce Microsoft Exce Microsoft Exce Microsoft Exce Microsoft Exce Microsoft Facet Microsoft Exce Microsoft E

5、xce代码如下：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(promptk"请选择拆分的表头,必须是第一

6、行, 一个单元格,如：“姓名 ", 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名为：数据源Sheets(i).De

7、leteEnd 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 =

8、CreateObject("adodb.connection")conn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName ' 201版连接字符Sql = "select * from 数据源 $ where " & title & " = '" & k(i) & ", Dim Nowb

9、ook As Workbook Set Nowbook = Workbooks.Add With 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 With End With ThisWorkbook.ActivateSheets(1).Cells.Select Selection.CopyWorkbook

10、s(Nowbook.Name).ActivateActiveSheet.Cells.SelectSelection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=FalseApplication.CutCopyMode = FalseNowbook.SaveAs ThisWorkbook.Path & "" & k(i) Nowbook.Close True Set Nowbook = NothingNext i conn.Clos

11、e Set conn = Nothing Application.DisplayAlerts = True Application.ScreenUpdating = True End Sub3、将含有多sheet的一个工作表,按 sheet名拆分为工作表sheetS Sheetl Sheet?国-Sheetl2022/9/12 11:15Microsoft Ex«l24 KB国5heet22022/9/12 11:15Microsoft Excel .24 KB国 sheets2022/9/12Microsoft Excel »»64 KB演商分2022/9/12

12、 15:57Microsoft Excd 一75 KB代码如下：Private Sub分拆工作表Dim sht As WorksheetDim MyBook As WorkbookSet MyBook = ActiveWorkbookFor Each sht In MyBook.Sheetssht.CopyActiveWorkbook.SaveAs Filename:=MyBook.Path &""& sht.Name,FileFormat:=xlNormal'将工作簿另存为 EXCELS认格式ActiveWorkbook.CloseNextMsgB

13、ox 文件已经被分拆完毕！End Sub4,、将多个工作薄合并为一个多sheet的工作薄勺 zgdxExcrell 1 )国-Excel (2)出T rgriK_Extze'l(3Jwdx_Exglr4)背1 zqdx Excel<5)W rgdx_f xcel(6)* zgdH_Exccl(7)国-xdx_Excvl(a);gdif_Excel(1J.FgrtcExceU君必电Ex.制 HJ | ?gdx_ExceH4；i rqdx_E蜕/(3) ;gdi(t)trel(6) /,代码如下：Sub Books2Sheets()'定义对话框变量Dim fd As File

14、DialogSet fd=Application.FileDialog(msoFileDialogFilePicker)'新建一个工作簿Dim newwb As WorkbookSet newwb=Workbooks.AddWith fdIf.Show=-1 Then'定义单个文件变量Dim vrtSelectedItem As Variant'定义循环量Dim i As Integer i=1'开始文件检索For Each vrtSelectedItem In.SelectedItems'翻开被合并工作簿Dim tempwb As WorkbookSe

15、t tempwb=Workbooks.Open(vrtSelectedItem)'复制工作表tempwb.Worksheets(1).Copy Before:=newwb.Worksheets(i),把新工作簿的工作表名字改成被复制工作簿文件名,这儿应用于 xls文件, 即Excel97-2022的文件,如果是 Excel2022,需要改成 xlsxnewwb.Worksheets(i).Name=VBA.Replace(tempwb.Name,".xls","")'关闭被合并工作簿tempwb.Close SaveChanges:=Fa

16、lse i=i+1 Next vrtSelectedItemEnd IfEnd WithSet fd=NothingEnd Sub5、将含有多个sheet的工作表内容信息汇总至一个sheet中SuCombine()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&qu