VBA-編程常見實例

1、2、將匯總的好的EXCEL1按字段拆分為多個工作薄武汶分公言1黃岡分公司襄E日分公司創(chuàng)陰分公司宜昌分公司孝博分公司十堰分公司代碼如下：Sub cfs()Dim GSArr() As String公司名稱清單Dim Rca As Integer 'A 列數(shù)據(jù)行數(shù)Dim i As IntegerDim Sn As StringSn = ActiveSheet.NameRca = Columns("A:A").End(xlDown).Row按第A列數(shù)據(jù)拆分，且第一行無合并單元格ReDim GSArr(1 To 1)GSArr(1) = Cells(2, 1)For i =

2、 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.ShowAllDataEnd IfF

3、or 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 Sub0首叮翁共享I胳口心 肥盒雙分公司年省網(wǎng)癮能O耆公司網(wǎng)發(fā)解 Q省公司網(wǎng)運手 口菖號百公司Q -瑁瑁值日心Q省終

4、其口心2016/9/12 14:572016/9/12 14; 572016/9/12 14胸2016/9/12 14162016/5/12 1416201679/12 14:162016；9/12 14162016/9/12 14:16201679/12 1416Microsoft Exce Microsoft Exce Microsoft Exce Microsoft Exce Microsoft Exce Microsoft Exce Microsoft Facet Microsoft Exce Microsoft Exce代碼如下：Sub CFGZB()Dim myRange As V

5、ariantDim myArrayDim titleRange As RangeDim title As StringDim columnNum As IntegermyRange = Application.InputBox(prompt:=" 請選擇標題行：", Type:=8)myArray = WorksheetFunction.Transpose(myRange)且為Set titleRange = Application.InputBox(promptk"請選擇拆分的表頭，必須是第一行, 一個單元格，如："姓名” ", Type:=

6、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 <> "數(shù)據(jù)源"Then待拆分的表sheet名為：數(shù)據(jù)源Sheets(i).DeleteEnd IfNext iSet d = Crea

7、teObject("Scripting.Dictionary")Myr = Worksheets("數(shù)據(jù)源").UsedRange.Rows.CountArr = Worksheets。'數(shù)據(jù)源").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.con

8、nection")conn.Open "provider=microsoft.ace.oledb.12.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName，013 版連接字符Sql = "select * from 數(shù)據(jù)源 $ where " & title & " = '" & k(i) & "”，Dim Nowbook As WorkbookSet Nowbook = Work

9、books.AddWith NowbookWith .Sheets。).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 WithThisWorkbook.ActivateSheets(1).Cells.SelectSelection.CopyWorkbooks(Nowbook.Name).ActivateActiveSheet.Cells.

10、SelectSelection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=FalseApplication.CutCopyMode = FalseNowbook.SaveAs ThisWorkbook.Path & "" & k(i)Nowbook.Close TrueSet Nowbook = NothingNext i conn.Close Set conn = Nothing Application.DisplayAler

11、ts = True Application.ScreenUpdating = True End Sub3、將含有多sheet的一個工作表，按 sheet名拆分為工作表sheetS Sheetl Sheet?國-Sheetl2016/9/12 11:15Microsoft Ex«l24 KB園15heet22016/9/12 11:15Microsoft Excel .24 KB國 sheets2016/9/12 11；15Microsoft Excel »»64 KB演商分2016/9/12 15:57Microsoft Excd 一75 KB代碼如下：Priva

12、te 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.CloseNextMsgBox ”文件已經(jīng)被分拆完畢！”End Sub4,、將多個工作薄合并為一

13、個多sheet的工作薄膽zgdxr_ Excel (1 zgdx Excel (Z)EgdK_Excel(3), 1 sg dw_ Exc I«)Ngd.E 乳匚 *1(5)fMf rg Hx-E xci&l (6)前j sgdxsEMCCil(7)11?gdK_Excel(lJ Fgdx_E»cel(Z zqcIx Encel(3) | ?gdr_Ex<el(4；i必電Ee?zgdx ExrM代碼如下：Sub Books2Sheets()定義對話框變量Dim fd As FileDialogSet fd=Application.FileDialog(msoF

14、ileDialogFilePicker)新建一個工作簿Dim newwb As WorkbookSet newwb=Workbooks.AddWith fdIf.Show=-1 Then定義單個文件變量Dim vrtSelectedItem As Variant定義循環(huán)量Dim i As Integeri=1開始文件檢索For Each vrtSelectedItem In.SelectedItems打開被合并工作簿Dim tempwb As WorkbookSet tempwb=Workbooks.Open(vrtSelectedItem)復(fù)制工作表tempwb.Worksheets.Cop

15、y Before:=newwb.Worksheets(i)把新工作簿的工作表名字改成被復(fù)制工作簿文件名，這兒應(yīng)用于xls文件,即Excel97-2003的文件，如果是 Excel2007,需要改成 xlsxnewwb.Worksheets(i).Name=VBA.Replace(tempwb.Name,".xls","")關(guān)閉被合并工作簿tempwb.Close SaveChanges:=False i=i+1Next vrtSelectedItemEnd IfEnd WithSet fd=NothingEnd Sub5、將含有多個sheet的工作表內(nèi)容

16、信息匯總至一個sheet中_丁 |吒 LmciI d *V jludenCj- inr ABCt>-I1Name Gendar Class AgeFinnMIDIS3M113aMd hi nwi F333NodihM 014修，* 川 (iridAl J MiKlF歲入I用一吟J illJ1幻 MnoMsift Encel -曷局與3主11' inf.口HU口wName Gendar Class AezL»raF2出垢M3IS4AgjilhJ MDi a息 urwM1914| l« 4 * *1 .小小 F | jj且，D J_ CD1 NameGendsir

17、 ClaKSAge7 JimM112m LucyF4 日由M1125 AlexiaMmii6 NellF5127 FredM413曲 NoclalF7125 JudnnuFA13ID）口內(nèi)M介1111 FlflnM101312 J。寸衽M11213 MidXijmlF31314 NoahM51也15 Leon leF912IB MiaF1131/ Laraf1ISIB NeleM31&M&1J工。AurcraM9321.FW1522 DdhaF21423 HeatherM6137 a iFwrir1BIS 0 2 .(口SuCombine。Dim J As IntegerOn Error Resume NextSheets.SelectWorksheets.AddSheets(1).Name = "Combined"Sheets(2).ActivateRange("A1").EntireRow.SelectSelection.Copy Destination:=Shee