VBA编程常见实例doc.doc

文档介绍：该【VBA编程常见实例doc 】是由【雨林书屋】上传分享，文档一共【6】页，该文档可以免费在线阅读，需要了解更多关于【VBA编程常见实例doc 】的内容，可以使用淘豆网的站内搜索功能，选择自己适合的文档，以下文字是截取该文章内的部分文字，如需要获得完整电子版，请下载此文档到您的设备，方便您编辑和打印。1、将excel汇总好的表,按字段拆分为多sheet的状况:以以下图:
代码以下:Subcfs()
DimGSArr()AsString'公司名称清单
DimRcaAsInteger'A列数据行数
DimiAsInteger
DimSnAsString
Sn=
Rca=Columns("A:A").End(xlDown).Row‘按第A列数据拆分,且第一行无合并单元格
ReDimGSArr(1To1)
GSArr(1)=Cells(2,1)
Fori=3ToRca
IfIsError((Cells(i,1),GSArr,0))Then
ReDimPreserveGSArr(1ToUBound(GSArr)+1)
GSArr(UBound(GSArr))=Cells(i,1)
EndIf
Next
=FalseThen
Rows("1:1").AutoFilter
Else
=
Fori=1ToUBound(GSArr)
:=1,Criteria1:=GSArr(i)
:=Sheets()
=GSArr(i)
Sheets(Sn).
Sheets(Sn).Activate
Next
EndSub
2、将汇总的好的EXCEL表按字段拆分为多个工作薄
代码以下:
SubCFGZB()
DimmyRangeAsVariant
DimmyArray
DimtitleRangeAsRange
DimtitleAsString
DimcolumnNumAsInteger
myRange=(prompt:="请选择标题行:",Type:=8)
myArray=(myRange)
SettitleRange=(prompt:="请选择拆分的表头,一定是第一行,且为一个单元格,如:“姓名”",Type:=8)
title=
columnNum=
=False
=False
Dimi&,Myr&,Arr,num&
Dimd,k
Fori=-1
IfSheets(i).Name<>"数据源"Then‘待拆分的表sheet名为:数据源
Sheets(i).Delete
EndIf
Nexti
Setd=CreateObject("")
Myr=Worksheets("数据源
Arr=Worksheets("数据源").Range(Cells(2,columnNum),Cells(Myr,columnNum))
Fori=1ToUBound(Arr)
d(Arr(i,1))=""
Next
k=
Fori=0ToUBound(k)
Setconn=CreateObject("")
"provider=;extendedproperties=;datasource="&‘2013版连接字符
Sql="select*from[数据源$]where"&title&"='"&k(i)&"'"
DimNowbookAsWorkbook
SetNowbook=
WithNowbook
(1)
.Name=k(i)
Fornum=1ToUBound(myArray)
.Cells(1,num)=myArray(num,1)
Nextnum
.Range("A2").(Sql)
EndWith
EndWith

Sheets(1).

Workbooks().Activate
:=xlPasteFormats,Operation:=xlNone,_SkipBlanks:=False,Transpose:=False
=False
&"\"&k(i)

SetNowbook=Nothing
Nexti

Setconn=Nothing
=True
=True
EndSub
3、将含有多sheet的一个工作表,按sheet名拆分为工作表
代码以下:
PrivateSub分拆工作表()
DimshtAsWorksheet
DimMyBookAsWorkbook
SetMyBook=ActiveWorkbook




Filename:=

&"\"

&,
FileFormat:=xlNormal

'将工作簿另存为

EXCEL默认格式

Next
MsgBox"文件已经被分拆达成!"
EndSub
4,、将多个工作薄合并为一个多sheet的工作薄
代码以下:
SubBooks2Sheets()
'定义对话框变量
DimfdAsFileDialog
Setfd=(msoFileDialogFilePicker)
'新建一个工作簿
DimnewwbAsWorkbook
Setnewwb=
Withfd
=-1Then
'定义单个文件变量
DimvrtSelectedItemAsVariant
'定义循环量
DimiAsInteger
i=1
'开始文件检索

'打开被合并工作簿
DimtempwbAsWorkbook
Settempwb=(vrtSelectedItem)
'复制工作表
(1).CopyBefore:=(i)
'把新工作簿的工作表名字改成被复制工作簿文件名,这儿应用于xls文件,
即Excel97-2003的文件,假如是Excel2007,需要改成xlsx
(i).Name=(,".xls","")
'关闭被合并工作簿
:=False
i=i+1
NextvrtSelectedItem
EndIf
EndWith
Setfd=Nothing
EndSub
5、将含有多个sheet的工作表内容信息汇总至一个sheet中
SubCombine()
DimJAsInteger
OnErrorResumeNext
Sheets(1).Select

Sheets(1).Name="Combined"
Sheets(2).Activate
Range("A1").
:=Sheets(1).Range("A1")
ForJ=
Sheets(J).Activate
Range("A1").Select
(1,0).Resize(-1).Select
:=Sheets(1).Range("A65536").End(xlUp)(2)
Next
EndSub