VBA编程实例.docx
《VBA编程实例.docx》由会员分享，可在线阅读，更多相关《VBA编程实例.docx（35页珍藏版）》请在冰豆网上搜索。
VBA编程实例
VBA编程实例
第九章工作表排序
本章只有一个范例文件，主要功能对活动工作簿中所有工作表进行排序。
算法说明:
1、统计活动工作簿中工作表的数量WsCount=Activeworkbook.worksheets.count
2、定义一个一维数组a（1towscount）主要用来存放活动工作簿中所有工作表名称字符串3、利用foreachwsinactiveworkbook.worksheets循环将活动工作簿中所有数量赋值给一维数组4、利用冒泡法对数组进行排序（源文件对排序单独写了一个过程）
5、利用worksheets的move方法以及sheets（i）（他代表工作簿中从左到右第i张工作表）移动工作表代码:
SubSortSheet（）
DimWsCountAsInteger
DimWsArray（）AsString
DimWsAsWorksheet
OnErrorResumeNext
WsCount=ActiveWorkbook.Worksheets.CountReDimWsArray（1ToWsCount）
IfActiveWorkbook.ProtectStructureThen
MsgBoxActiveWorkbook.Name&"被保护，不能进行排序，请解除保护后排序",_
vbCritical,"不能排序工作表"
ExitSub
EndIf
ForEachWsInActiveWorkbook.Worksheets
t=t+1
WsArray（t）=Ws.Name
NextWs
'对数组进行排序
Fori=1ToUBound（WsArray）-1
Forj=i+1ToUBound（WsArray）
IfWsArray（i）>WsArray（j）Then
t=WsArray（i）
WsArray（i）=WsArray（j）
WsArray（j）=t
EndIf
Nextj
Nexti
'利用Move方法以及Sheets（i）移动工作表，按指定的顺序排列
Fori=1ToWsCount
Worksheets（WsArray（i））.Movebefore:
=Sheets（i）Nexti
EndSub
第七章批注
1、Comment为Range对象的属性
2、Comments返回指定工作表中所有的批注，可以利用Foreach对工作表中所有批注循环题目:
（1）根据批注的作者，删除批注
（2）隐藏工作表中所有批注
（3）为区域中添加批注
（4）测试Comments（index）返回指定工作表中第index个批注
Sub统计批注个数（）
DimFlagAsComment
'1、Comments返回指定工作表中所有的批注
'2、用Comment属性返回一个Comment对象
ForEachFlagInActiveSheet.Comments
t=t+1
NextFlag
MsgBox"活动工作表中共有:
"&t&"个批注",vbOKOnly,"统计批注个数"EndSub
SubCountComment（）
DimFlagAsRange
'利用err来判断是否发生错误
ForEachFlagInActiveSheet.UsedRange
OnErrorResumeNext
t=Flag.Comment.Text
IfErr=0Thenk=k+1NextFlag
MsgBox"活动工作表中共有:
"&k&"个批注",vbOKOnly,"统计批注个数"EndSub
Sub选定批注单元格（）
Dima（）AsRange
DimFlagAsRange
ReDima（ActiveSheet.Comments.Count）Fori=1ToActiveSheet.Comments.Count
Seta（i-1）=ActiveSheet.Comments（i）.Parent
Nexti
SetFlag=a
Flag.Select
EndSub
Subselectcomment（）
'使用编辑定位功能，定位批注，选定单元格
Cells.SpecialCells（xlCellTypeComments）.Select
EndSub
Sub显示或隐藏批注（）
DimFlagAsComment
ForEachFlagInActiveSheet.Comments
IfFlag.Visible=TrueThen
Flag.Visible=False
Else
Flag.Visible=True
EndIf
NextFlag
EndSub
SubDisHideComment（）
'利用application的displaycommentindicator属性来显示隐藏批注
'Indicator表示批注的标识符
IfApplication.DisplayCommentIndicator=xlCommentAndIndicatorThen
Application.DisplayCommentIndicator=xlCommentIndicatorOnly
Else
Application.DisplayCommentIndicator=xlCommentAndIndicator
EndIf
EndSub
Sub输出所有批注（）
'在Sheet2工作表中返回Sheet1工作表中所有批注
'这里使用ment.text返回批注中的内容
DimFlagAsComment
DimtAsInteger
i=1
WithWorksheets（"Sheet2"）
.Cells.Clear
.Cells（1,1）="第n个批注"
.Cells（1,2）="批注地址"
.Cells（1,3）="批注内容"
ForEachFlagInWorksheets（"Sheet1"）.Comments
i=i+1
t=t+1
.Cells（i,1）=t
.Cells（i,2）=Flag.Parent.Address
.Cells（i,3）=Flag.Parent.Comment.Text
NextFlag
.Columns（"B:
B"）.EntireColumn.AutoFit
.Columns（"C:
C"）.ColumnWidth=34
.Cells.EntireRow.AutoFit
EndWith
EndSub
Sub改变批注颜色（）
DimFlagAsComment
ForEachFlagInActiveSheet.Comments
Flag.Shape.Fill.ForeColor.SchemeColor=Int（（80）*Rnd+1）'1-80
Flag.Shape.TextFrame.Characters.Font.ColorIndex=Int（（56）*Rnd+1）'1-56
NextFlag
EndSub
Sub添加批注（）
DimFlagAsRange
OnErrorResumeNext
ForEachFlagInActiveSheet.Range（"g8:
i17"）
t=t+1
Flag.AddComment.Text"hner:
这是我添加的第"&t&"个批注"&Chr（13）+Chr（10）&Date
NextFlag
EndSub
Subtest（）
MsgBoxActiveSheet.Range（"g8"）.Comment.Author
EndSub
Sub删除批注（）
DimFlagAsRange
ForEachFlagInActiveSheet.Range（"g8:
i17"）
Flag.Comment.Delete
NextFlag
EndSub
第十章自定义函数
函数一:
计算销售佣金
题1:
根据销售额和对应的佣金率计算=Sales*Rate题2:
根据销售额和对应的佣金率以及工作年限计算，工作每满一年佣金在原来的基础上增加一个百分点
=Sales*Rate*（1+Year/100）
条件临界点佣金率
[0，10000）00.08
[10000，20000）100000.105
[20000，40000）200000.12
[40000，无穷）400000.14
计算方法:
1、利用vlookup函数的模糊查找:
=VLOOKUP（B2,$B$14:
$C$17,2,TRUE）*B2定期维护佣金率
2、利用if函数结合&连接符突破if七层嵌套问题:
=IF（AND（B2>=0,B2<$B$15）,B2*$C$14,""）
&IF（AND（B2>=$B$15,B2<$B$16）,B2*$C$15,""）&IF（AND（B2>=$B$16,B2<$B$17）,B2*$C$16,""）&IF（AND（B2>=
$B$17）,B2*$C$17,""）
3、利用自定义函数，代码如下:
FunctionCommission1（Sales,years）'计算销售佣金，工作每满一年，销售佣金在原来的基础上增加一个百分点ConstRate1=0.08
ConstRate2=0.105
ConstRate3=0.12
ConstRate4=0.14
SelectCaseSales
Case0To9999.99'Caseatob表示[a,b]两边都是闭区间
Commission1=Sales*Rate1
Case10000To19999.99
Commission1=Sales*Rate2
Case20000To39999.99
Commission1=Sales*Rate3
CaseElse
Commission1=Sales*Rate4EndSelect
'每工作满一年，佣金在原来的基础上增加1个百分点
Commission1=Commission1*（1+years/100）
EndFunction
Sub计算销售佣金（）
’在工作表中设计一个窗体按钮，执行此代码
DimSales
DimyearsAsInteger
Sales=Val（InputBox（"请输入销售额:
","计算销售佣金"））
years=Val（InputBox（"请输入工作年限:
","计算销售佣金"））
y=MsgBox（"您的佣金为:
"&Commission1（Sales,years）,vbYesNo,"计算销售佣金"）Ify=vbYesThen'这里使用msgbox信息框，当单击是的时候，调用该过程本身计算销售佣金EndIf
EndSub
函数二:
随机抽取某区域中的一个单元格
目的:
理解Optional定义变量和非易失性函数Volatile
1、易失性函数:
顾名思义该函数很容易改变，也就是无论何时在工作表任意单元格输入数据，易失性函数都需要重新计算，结合本例，只要在任意单元格输入数据，易失性函数都重新计算2、非易失性函数:
顾名思义该函数不容易改变，也就是只有在函数中的参数值发生变化时，非易失性函数才重新计算，否则不计算，结合本例，只有在a1:
a10输入数据，非易失性函数才重新计算，否则不计算3、Optional申明变量，表示该变量为可选参数
4、假如Region为一个range对象区域，那么Region（i）表示区域Region中第i个对象
代码如下:
FunctionUnderstandVolatile（RegionAsRange,OptionalFlagBooleanAsBoolean=False）
'利用optional定义变量表示该变量为可选参数
'理解非易失性函数
'函数功能:
随机抽取Region区域中的一个单元格值
'当application.volatiletrue时，表示易失性函数
Application.VolatileFlagBoolean
'产生[a,b]之间的随机整数Int（rnd（）*（b-a+1）+1）
UnderstandVolatile=Region（Int（Rnd（）*（Region.Count）+1））
EndFunction
函数三:
利用Optional来确定自定义函数是一个多单元格数组函数还是一个普通函数MonthNames（Optional
Mindex）
函数功能:
返回月份
可选参数:
1、当无参数时，返回一个多单元格数组公式，横向数组，将一个数组直接赋值给自定义函数2、当参数大于等于1时，返回对应月份，如参数为1，则返回Jan，参数为13，也同样返回Jan3、当参数小于等于0时，返回一个多单元格数组公式，垂直数组
代码如下:
FunctionMonthNames（OptionalMindex）'返回月份
'Ismissing（t）表示t是否传递给过程，如果没有传递，则返回true
DimAllNamesAsVariant
AllNames=Array（"Jan","Feb","Mar",_
"Apr","May","Jun","Jul","Aug",_
"Sep","Oct","Nov","Dec"）
IfIsMissing（Mindex）Then
MonthNames=AllNames
Else
SelectCaseMindex
CaseIs>=1
'如果参数为1，则返回Jan，为数组的第一个元素，故应该用（Mindex-1mod12），数组的下限为0，即AllNames（0）
MonthNames=AllNames（（Mindex-1）Mod12）
CaseElse
MonthNames=Application.WorksheetFunction.Transpose（AllNames）
EndSelect
EndIf
EndFunction
这里使用一个ismissing函数，该函数主要是用来测试是否将参数传递给过程，如果没有传递，则返回TRUE。
如:
在工作表中输入=MonthNames（）此时并没有传递参数给过程
函数四:
颠倒字符串
目的:
运用vba函数和如何操作字符串
vba函数:
1、StrReverse（String）返回反向字符串，当string为空值时，则函数返回空字符窜，如果无参数，则返回null2、MID（String,i,n）从字符串string的第i个位置开始提取长度为n的字符串
函数使用fori=len（string）to1step-1
n=mid（string,i,1）
'遍历字符串中的每个字符，此方法可以运用到数字与字符分离或者字符串中各数字求和等
nexti
FunctionMstrReverse（Mstring）AsString'利用vba函数StrReverse返回反向字符串
MstrReverse=VBA.StrReverse（Mstring）EndFunction
FunctionMstrreverse1（Mstring）AsStringDimiAsInteger
Fori=Len（Mstring）To1Step-1
Mstrreverse1=Mstrreverse1&Mid（Mstring,i,1）Nexti
EndFunction
SubMstrreverse2（）
Mstring=InputBox（"请输入字符串:
","反向字符串"）
IfMstring=""ThenExitSub
MsgBox"字符串:
"&Mstring&"的反向字符串为:
"&vbCrLf&MstrReverse（Mstring）,vbOKOnly,"反向字符串"
EndSub
小窍门:
在实际输入vba代码时，可能没有熟记vba常量或者vba函数，此时可以在vbe中按ctrl+j返回常数列表，供选择。
或者输入vba.则返回vba函数供选择。
函数五:
字符串全部大写或者全部小写AlUcLcase（Mstring,OptionalMbooleanAsBoolean=True）
算法:
、遍历字符串中的每个字符1
2、对字符串中的每个字符进行判断
条件一:
如果函数的第二个参数省略或者第二个参数为TRUE时，表示要将字符串全部大写、如果ASC（字符）在[97，122]，那么，表示该字母为小写字母需要转换。
转换字符=CHR（ASC（字符）-32）1
2、如果不满足上述条件，表示字母表示大写字母或者非字母，此时不需要转换，只需字符连接条件二:
如果函数的第二个参数为False时，表示要将字符串全部小写
1、如果ASC（字符）在[65，90]，那么，表示该字母为大写字母需要转换。
转换字符=CHR（ASC（字符）+32）2、如果不满足上述条件，表示字母表示小写字母或者非字母，此时不需要转换，只需字符连接
vba函数
1、ASC（字符）表示返回字符的ASICC码，相当于EXCEL工作表中的CODE函数
2、CHR（数字）表示返回数字对应的字符，相当于EXCEL工作表中的CHAR函数
3、UCASE（字符）表示将字符全部大写，相当于EXCEL工作表中的UPPER函数
、LCASE（字符）表示将字符全部小写，相当于EXCEL工作表中的LOWER函数4
代码如下:
FunctionAlUcLcase（Mstring,OptionalMbooleanAsBoolean=True）AsString
'字符串大小写转换，如果省略第二个参数，则将字符串全部大写显示，否则小写显示DimiAsInteger
DimMlenAsInteger
DimSngStringAsString
DimMcodeAsInteger
DimAimStringAsString
Mlen=Len（Mstring）
Fori=1ToMlen
SngString=VBA.Mid$（Mstring,i,1）
Mcode=VBA.Asc（SngString）
'注意下面的条件，Ismissing表示当参数省略时，或者当参数为True时，表示将字符串全部大写
IfIsMissing（Mboolean）OrMboolean=TrueThen
IfMcode>=97AndMcode<=122Then
AimString=AimString&VBA.Chr（Mcode-32）
Else
AimString=AimString&SngString
EndIf
Else
IfMcode>=65AndMcode<=90Then
AimString=AimString&VBA.Chr（Mcode+32）
Else
AimString=AimString&SngString
EndIf
EndIf
Nexti
AlUcLcase=AimString
EndFunction
FunctionAlUcLcase1（Mstring,OptionalMbooleanAsBoolean=True）AsString
'字符串大小写转换，如果省略第二个参数，则将字符串全部大写显示，否则小写显示IfIsMissing（Mboolean）OrMboolean=TrueThen
AlUcLcase1=VBA.UCase$（Mstring）Else
AlUcLcase1=VBA.LCase$（Mstring）
EndIf
EndFunction
Excel2003高级VBA编程---第11章VBA编程示例和技巧
实例一:
利用EXCEL的FileSearch属性批处理查找文件
下面实例主要论证以下几个问题:
1、Application的FileSearch属性，该属性返回一个FoundFiles对象，也就是根据指定的条件，查找出来的满
足条件的文件集合，可以利用Foreach对该集合进行循环。
如:
要查找D盘根目录下，所有TXT文件
'下面的代码返回一个FoundFiles属性
WithApplication.FileSearch
.LookIn="c:
\"
.FileName="*.txt"
.Execute
'对上述属性进行操作
i=1
foreachfsin.FoundFiles
withactivesheet
.cells（1,1）="序号"
.cells（1,2）="路径"
i=i+1
.cells（I,1）=I
.cells（I,2）=fs
endwith
nextfs
2、利用工作簿的opentext方法，将文本文件导入到工作表中
3、过程调用，如果某些过程比较通用，最好使用该方法，以提高代码编写效率
具体实例:
SubFileProcess（）
'文件批处理，将某文件夹下所有文本文件导入到excel工作簿中DimFileFindAsFileSearch
DimfsAsVariant
DimFilePathAsString
DimFileStyleAsString
FilePath=ThisWorkbook.Path&"\"FileStyle="*.txt"
WithApplication.FileSearch
.LookIn=FilePath
.Filename=FileStyle
.Execute
If.FoundFiles.Count=0Then
MsgBox"没有找
升级会员 