vba编程常见实例

1、1、将excel汇总好的表，按字段拆分为多sheet的情况：如下图:武汉分公目黄冈分公司襄汨分公司制M分公司宜昌分公司孝慈分公司十堰分公司 代码如下：Sub cfs()Dim GSArr() As String公司名称清单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 Rc

2、aIf IsError(Cells(i, 1), GSArr, 0) ThenReDim Preserve GSArr(1 To UBound(GSArr) + 1)GSArr(UBound(GSArr) = Cells(i, 1)End IfNextIf = False ThenRows("1:1").AutoFilterElseIf = True ThenEnd IfFor i = 1 To UBound(GSArr)Field:=1, Criteria1:=GSArr(i)After:=Sheets=GSArr(i)Sheets(Sn).Sheets(Sn).Acti

3、vateNextSub2、将汇总的好的EXCEL1按字段拆分为多个工作薄E3省叵翁共享1一白心段汉分公司小首网翟骡Co耆公司网友部 b言公司网运籥 口省号百公司 口;百赠值由心 a省终其日心2016/9/12 14:572016/5/12 14x572016/9/12 14:402016/9/12 14162016/9/12 14i1&2016/9/12 14:162D16；g/12 1416 2016/9/12 14:16 2016/9/12 1416Microsoft ExcelMicrosoft ExcelMicrosoft ExcelMlcrasoft Excel .Micro

4、soft ExcelMicrosoft Excel Microsoft Ex«l Microsoft Excel Microsoft Excel .代码如下：Sub CFGZB()Dim myRange As VariantDim myArrayDim titleRange As RangeDim title As StringDim columnNum As IntegermyRange = (promptk”请选择标题行：", Type:=8)myArray = (myRange)Set titleRange = (promptk"请选择拆分的表头， 必须是第

5、一行，且为一个单元格，如：“姓名” "，Type:=8)title =columnNum =False=FalseDim i&, Myr&, Arr, num&Dim d, kFor i = To 1 Step -1If Sheets(i).Name <> "数据源"Then待拆分的表 sheet名为：数据源Sheets(i).DeleteEnd IfNext iSet d = CreateObject("")Myr = Worksheets("数据源"). Arr = Worksheet

6、s("数据源").Range(Cells(2, columnNum), Cells(Myr, columnNum)For i = 1 To UBound(Arr)d(Arr(i, 1)=""Next k =For i = 0 To UBound(k)Set conn = CreateObject("")"provider= properties=excel ;data source=" &2013 版连接字符Sql = "select * from 数据源 $ where " &

7、 title & " = '" & k(i) & "”，Dim Nowbook As WorkbookSet Nowbook =With NowbookWith .Sheets(1).Name = k(i)For num = 1 To UBound(myArray).Cells(1, num) = myArray(num, 1)Next num.Range("A2").CopyFromRecordset (Sql)End WithEnd WithSheets(1).Workbooks.ActivatePaste:

8、=xlPasteFormats, Operation:=xlNone, _SkipBlanks:=False, Transpose:=False= False& "" & k(i)TrueSet Nowbook = NothingNext iSet conn = Nothing= True= TrueEnd Sub3、将含有多sheet的一个工作表，按 sheet名拆分为工作表sheets SheetlEnd Sub虾 Sheet2016/9/12 11:15Microsoft Excel24 KBSheets2016/9/1211:15Microsoft

9、Excel.24 KB国* sheets2016/9/12 11:15Micro&cft Excel &4 KB疝|铸折分2016/9/12 15:57Microsoft Excel.75 KB代码如下：Private Sub分拆工作表（）Dim sht As WorksheetDim MyBook As WorkbookSet MyBook = ActiveWorkbookFor Each sht InFilename:= & "" & , FileFormat:=xlNormal'将工作簿另存为 EXCE蹴认格NextMsgBox

10、 ”文件已经被分拆完毕4,、将多个工作薄合并为一个多sheet的工作薄£Excel (1 )FSETExcel(2)rgdx_Excrel(3) 切孑 zgdx_ Exce I (4) 国 m)cIm_Ex匚.lf5) zgd k_E reel (6) E igdK_Exccl(7) Excel (&)7g(k_E“£l(l TgE_Ex'ceU 刁 必 间 H】 7g<jx_Exftl(4；rqd箕一ExraGi?gdx twN (曰代码如下:Sub Books2Sheets()定义对话框变量Dim fd As FileDialogSet fd=(m

11、soFileDialogFilePicker)新建一个工作簿Dim newwb As WorkbookSet newwb=With fd=-1 Then'定义单个文件变量Dim vrtSelectedItem As Variant'定义循环量Dim i As Integeri=1'开始文件检索For Each vrtSelectedItem'打开被合并工作簿Dim tempwb As WorkbookSet tempwb=(vrtSelectedItem)'复制工作表(1).Copy Before:=(i)把新工作簿的工作表名字改成被复制工作簿文件名，这

12、儿应用于xls文件,即Excel97-2003的文件，如果是Excel2007,需要改成xlsx(i).Name=,".xls","")'关闭被合并工作簿SaveChanges:=Falsei=i+1Next vrtSelectedItemEnd IfEnd WithSet fd=Nothing5、将含有多个sheet 的工作表内容信息汇总至一个sheet 中End Subj"/Eygfrl p -! ituemW,A | D _ c 1&1d5Name Gendlar CImi A1gJimM1123胃F213RgM117Ai

13、BMiaM311ABC口1Name Gemdar ClassFinnMAge ID13JOn4!M112小Mjiimii aS3NCdihM01414fr *1 _ grad. j (W;kImJ1 Jr»do3 _t FJ .互| Z, ViEy打 Fkf 4l| TtudTHTi inf.-4D；DT1 ihJa>me Gendar Class Ae2 JimM3123 LucyFN4 日 gM1id5 Alexia M31116 Nell/F512l7 Fred£ M4111莒 Ncclal F7129 J DJinn aFfl-1110 *1幅 gfiiM守11IL FinnMIQ1312 JondfM11213 MidXEml F31314 NoahM61315 Lecriiie F912IB MiaF1lj|1/ Laraf115lin Nlem3iel19M4ijIHQ AurCTA M5词21 B«UVFW1522 l?elMFN3。23 Heather M613IJ24.FB15 wSub Combine。Dim J As IntegerOn Error Resume NextSheets(1).SelectSheets(1).Name = "Combined"Sheets(2).Ac