第8章函数的使用代码超实用VBA.docx
《第8章函数的使用代码超实用VBA.docx》由会员分享，可在线阅读，更多相关《第8章函数的使用代码超实用VBA.docx（12页珍藏版）》请在冰豆网上搜索。
第8章函数的使用代码超实用VBA
第8章函数的使用
范例119使用时间和日期函数
119-1计算程序运行时间
SubMyTime（）
DimiAsInteger
DimStartTimeAsSingle
DimEndTimeAsSingle
StartTime=Timer
Fori=1To10000
Cells（1,1）=i
Next
EndTime=Timer-StartTime
MsgBox"程序运行时间：
"&Format（EndTime,"0.00"）&"秒"
EndSub
119-2获得当月的最后一天
SubEndday（）
DimEnddayAsByte
Endday=Day（DateSerial（Year（Date）,Month（Date）+1,0））
MsgBox"当月最后一天是"&Month（Date）&"月"&Endday&"号"
EndSub
119-3计算某个日期为星期几
SubMyweekday（）
DimStrDateAsString
DimMyweekdayAsString
StrDate=InputBox（"请输入日期：
"）
IfLen（StrDate）=0ThenExitSub
IfIsDate（StrDate）Then
SelectCaseWeekday（StrDate,vbSunday）
CasevbSunday
Myweekday="星期日"
CasevbMonday
Myweekday="星期一"
CasevbTuesday
Myweekday="星期二"
CasevbWednesday
Myweekday="星期三"
CasevbThursday
Myweekday="星期四"
CasevbFriday
Myweekday="星期五"
CasevbSaturday
Myweekday="星期六"
EndSelect
MsgBoxDateValue（StrDate）&""&Myweekday
Else
MsgBox"请输入正确格式的日期!
"
EndIf
EndSub
119-4计算两个日期的时间间隔
SubDateInterval（）
DimStrDateAsString
StrDate=InputBox（"请输入日期：
"）
IfLen（StrDate）=0ThenExitSub
IfIsDate（StrDate）Then
MsgBoxDateValue（StrDate）&Chr（13）&"距离今天有"_
&Abs（DateDiff（"d",Date,StrDate））&"天"
Else
MsgBox"请输入正确格式的日期!
"
EndIf
EndSub
119-5获得指定时间间隔的日期
SubMyDateAdd（）
DimStrDateAsString
StrDate=Application.InputBox（Prompt:
="请输入间隔的天数：
",Type:
=1）
IfStrDate=FalseThenExitSub
MsgBoxStrDate&"天后的日期是"&DateAdd（"d",StrDate,Date）
EndSub
119-6格式化时间和日期
SubTimeDateFormat（）
DimStrAsString
Str=Format（Now,"MediumTime"）&Chr（13）_
&Format（Now,"LongTime"）&Chr（13）_
&Format（Now,"ShortTime"）&Chr（13）_
&Format（Now,"GeneralDate"）&Chr（13）_
&Format（Now,"LongDate"）&Chr（13）_
&Format（Now,"MediumDate"）&Chr（13）_
&Format（Now,"ShortDate"）
MsgBoxStr
EndSub
范例120使用字符串处理函数
SubStrFunctions（）
DimStrAsString
Str="UseStringFunctions"
MsgBox"原始字符串：
"&Str&Chr（13）_
&"字符串长度：
"&Len（Str）&Chr（13）_
&"左边8个字符：
"&Left（Str,8）&Chr（13）_
&"右边6个字符：
"&Right（Str,6）&Chr（13）_
&"""Str""出现在字符串的第"&InStr（Str,"Str"）&"位"&Chr（13）_
&"从左边第5个开始取6个字符：
"&Mid（Str,5,6）&Chr（13）_
&"转换为大写：
"&UCase（Str）&Chr（13）_
&"转换为小写：
"&LCase（Str）&Chr（13）
EndSub
范例121判断表达式是否为数值
SubMyNumeric（）
DimrAsInteger
DimrngAsRange
DimYnumberAsString
DimNnumberAsString
r=Cells（Rows.Count,1）.End（xlUp）.Row
ForEachrngInRange（"A1:
A"&r）
IfIsNumeric（rng）Then
Ynumber=Ynumber&rng.Address（0,0）&vbTab&rng&vbCrLf
Else
Nnumber=Nnumber&rng.Address（0,0）&vbTab&rng&vbCrLf
EndIf
Next
MsgBox"数值单元格：
"&vbCrLf&Ynumber&vbCrLf_
&"非数值单元格：
"&vbCrLf&Nnumber
EndSub
范例122自定义数值格式
SubCustomDigitalFormat（）
DimMyNumericAsDouble
DimStrAsString
MyNumeric=123456789
Str=Format（MyNumeric,"0.00"）&vbCrLf_
&Format（MyNumeric,"0%"）&vbCrLf_
&Format（MyNumeric,"#,##0.00"）&vbCrLf_
&Format（MyNumeric,"$#,##0.00"）&vbCrLf_
&Format（-（MyNumeric）,"￥#,##0.00;（￥#,##0.00）"）
MsgBoxStr
EndSub
范例123四舍五入运算
SubRounding（）
MsgBoxRound（4.56789,2）
EndSub
SubAmendmentsRound（）
MsgBoxRound（2.5+0.0000001）
EndSub
SubSheetsRound（）
MsgBoxApplication.Round（2.5,0）
EndSub
范例124使用Array函数创建数组
OptionBase1
SubMyarr（）
DimarrAsVariant
DimiAsInteger
arr=Array（"王晓明","吴胜玉","周志国","曹武伟","张新发","卓雪梅","沈煜婷","丁林平"）
Fori=LBound（arr）ToUBound（arr）
Cells（i,1）=arr（i）
Next
EndSub
范例125将字符串按指定的分隔符分开
SubSplitarr（）
DimArrAsVariant
Arr=Split（Cells（1,2）,","）
Cells（1,1）.Resize（UBound（Arr）+1,1）=Application.Transpose（Arr）
EndSub
范例126使用动态数组去除重复值
SubSplitarr（）
DimSplarr（）AsString
DimArr（）AsString
DimTemp（）AsString
DimrAsInteger
DimiAsInteger
OnErrorResumeNext
Splarr=Split（Range（"B1"）,","）
Fori=0ToUBound（Splarr）
Temp=Filter（Arr,Splarr（i））
IfUBound（Temp）<0Then
r=r+1
ReDimPreserveArr（1Tor）
Arr（r）=Splarr（i）
EndIf
Next
Range（"A1"）.Resize（r,1）=Application.Transpose（Arr）
EndSub
范例127调用工作表函数
127-1使用Sum函数求和
SubSumCell（）
DimrAsInteger
DimrngAsRange
DimDsumAsDouble
r=Cells（Rows.Count,1）.End（xlUp）.Row
Setrng=Range（"A1:
F"&r）
Dsum=Application.WorksheetFunction.Sum（rng）
MsgBoxrng.Address（0,0）&"单元格的和为"&Dsum
EndSub
127-2查找工作表中最大、最小值
SubFindMaxAndMin（）
DimrAsInteger
DimRngAsRange,MyRngAsRange
DimMaxCountAsInteger,MainCountAsInteger
DimMymaxAsDouble,MyminAsDouble
r=Cells（Rows.Count,1）.End（xlUp）.Row
SetMyRng=Range（"A1:
J"&r）
ForEachRngInMyRng
IfRng.Value=WorksheetFunction.max（MyRng）Then
Rng.Interior.ColorIndex=3
MaxCount=MaxCount+1
Mymax=Rng.Value
ElseIfRng.Value=WorksheetFunction.min（MyRng）Then
Rng.Interior.ColorIndex=5
MainCount=MainCount+1
Mymin=Rng.Value
Else
Rng.Interior.ColorIndex=0
EndIf
Next
MsgBox"最大值是：
"&Mymax&"，共有"&MaxCount&"个。
"_
&Chr（13）&"最小值是：
"&Mymin&"，共有"&MainCount&"个。
"
EndSub
127-3不重复值的录入
PrivateSubWorksheet_Change（ByValTargetAsRange）
WithTarget
If.Column<>1Or.Count>1ThenExitSub
IfWorksheetFunction.CountIf（Range（"A:
A"）,.Value）>1Then
.Select
MsgBox"不能输入重复的数据!
",64
Application.EnableEvents=False
.Value=""
Application.EnableEvents=True
EndIf
EndWith
EndSub
范例128个人所得税自定义函数
PublicFunctionPITax（Income,OptionalThreshold）AsDouble
DimRateAsDouble
DimDeductionAsDouble
DimTaxliabilityAsDouble
IfIsMissing（Threshold）ThenThreshold=2000
Taxliability=Income-Threshold
SelectCaseTaxliability
Case0To500
Rate=0.05
Deduction=0
Case500.01To2000
Rate=0.1
Deduction=25
Case2000.01To5000
Rate=0.15
Deduction=125
Case5000.01To20000
Rate=0.2
Deduction=375
Case20000.01To40000
Rate=0.25
Deduction=1375
Case40000.01To60000
Rate=0.3
Deduction=3375
Case60000.01To80000
Rate=0.35
Deduction=6375
Case80000.01To10000
Rate=0.4
Deduction=10375
CaseElse
Rate=0.45
Deduction=15375
EndSelect
IfTaxliability<=0Then
PITax=0
Else
PITax=Application.Round（Taxliability*Rate-Deduction,2）
EndIf
EndFunction
范例129人民币大写函数
PublicFunctionYuanCapital（Amountin）
YuanCapital=Replace（Application.Text（Round（Amountin+0.00000001,2）,"[DBnum2]"）,".","元"）
YuanCapital=IIf（Left（Right（YuanCapital,3）,1）="元",Left（YuanCapital,Len（YuanCapital）-1）&"角"&Right（YuanCapital,1）&"分",IIf（Left（Right（YuanCapital,2）,1）="元",YuanCapital&"角整",IIf（YuanCapital="零","",YuanCapital&"元整"）））
YuanCapital=Replace（Replace（Replace（Replace（YuanCapital,"零元零角",""）,"零元",""）,"零角","零"）,"-","负"）
EndFunction
范例130判断工作表是否为空表
FunctionIsBlankSht（ShAsVariant）AsBoolean
IfTypeName（Sh）="String"ThenSetSh=Worksheets（Sh）
IfApplication.CountA（Sh.UsedRange.Cells）=0Then
IsBlankSht=True
EndIf
EndFunction
SubDelBlankSht（）
DimShAsWorksheet
ForEachShInThisWorkbook.Sheets
IfIsBlankSht（Sh）Then
Application.DisplayAlerts=False
Sh.Delete
Application.DisplayAlerts=True
EndIf
Next
SetSh=Nothing
EndSub
范例131查找指定工作表
FunctionExistSh（ShAsString）AsBoolean
DimShtAsWorksheet
OnErrorResumeNext
SetSht=Sheets（Sh）
IfErr=0ThenExistSh=True
SetSht=Nothing
EndFunction
SubNotSht（）
DimShAsString
Sh=InputBox（"请输入工作表名称：
"）
IfLen（Sh）>0Then
IfNotExistSh（Sh）Then
MsgBox"对不起,"&Sh&"工作表不存在!
"
Else
Sheets（Sh）.Select
EndIf
EndIf
EndSub
范例132查找指定工作簿
FunctionExistWorkbook（WbNameAsString）AsBoolean
DimWbAsWorkbook
OnErrorResumeNext
SetWb=Workbooks（WbName）
IfErr=0ThenExistWorkbook=True
SetWb=Nothing
EndFunction
SubNotWorkbook（）
DimWbAsString
Wb=InputBox（"请输入工作簿名称：
"）
IfLen（Wb）>0Then
IfNot（ExistWorkbook（Wb））Then
MsgBoxWb&"工作簿没有打开!
"
EndIf
EndIf
EndSub
【代码解析】自定义ExistWorkbook函数判断指定名称的工作簿是否打开。
第5行代码，判断第4行代码是否出错，如果出错，则表示指定名称的工作簿没有打开，自定义ExistWorkbook函数返回False。
使用自定义ExistWorkbook函数可以判断指定名称的工作簿是否打开，范例代码如下：
#001SubNotWorkbook（）
#002DimWbAsString
#003Wb=InputBox（"请输入工作簿名称：
"）
#004IfLen（Wb）>0Then
#005IfNot（ExistWorkbook（Wb））Then
#006MsgBoxWb&"工作簿没有打开!
"
#007EndIf
#008EndIf
#009EndSub
范例133取得应用程序的安装路径
FunctionGetSetupPath（AppNameAsString）
DimWshAsObject
SetWsh=CreateObject（"Wscript.Shell"）
GetSetupPath=Wsh.RegRead（"HKEY_LOCAL_MACHINE\Software"_
&"\Microsoft\Windows\CurrentVersion\AppPaths\"_
&AppName&"\Path"）
SetWsh=Nothing
EndFunction
SubWinRARPath（）
MsgBoxGetSetupPath（"WinRAR.exe"）
EndSub
升级会员 