第8章--函数的使用代码【超实用VBA】

84第8章函数的使用范例119使用时间和日期函数119-1计算程序运行时间SubMyTime()DimiAsIntegerDimStartTimeAsSingleDimEndTimeAsSingleStartTime=TimerFori=1To10000Cells(1,1)=iNextEndTime=Timer-StartTimeMsgBox程序运行时间：&Format(EndTime,0.00)&秒EndSub119-2获得当月的最后一天SubEndday()DimEnddayAsByteEndday=Day(DateSerial(Year(Date),Month(Date)+1,0))MsgBox当月最后一天是&Month(Date)&月&Endday&号EndSub119-3计算某个日期为星期几SubMyweekday()DimStrDateAsStringDimMyweekdayAsStringStrDate=InputBox(请输入日期：)IfLen(StrDate)=0ThenExitSubIfIsDate(StrDate)ThenSelectCaseWeekday(StrDate,vbSunday)CasevbSunday85Myweekday=星期日CasevbMondayMyweekday=星期一CasevbTuesdayMyweekday=星期二CasevbWednesdayMyweekday=星期三CasevbThursdayMyweekday=星期四CasevbFridayMyweekday=星期五CasevbSaturdayMyweekday=星期六EndSelectMsgBoxDateValue(StrDate)&&MyweekdayElseMsgBox请输入正确格式的日期!EndIfEndSub119-4计算两个日期的时间间隔SubDateInterval()DimStrDateAsStringStrDate=InputBox(请输入日期：)IfLen(StrDate)=0ThenExitSubIfIsDate(StrDate)ThenMsgBoxDateValue(StrDate)&Chr(13)&距离今天有_&Abs(DateDiff(d,Date,StrDate))&天ElseMsgBox请输入正确格式的日期!EndIfEndSub119-5获得指定时间间隔的日期SubMyDateAdd()DimStrDateAsStringStrDate=Application.InputBox(Prompt:=请输入间隔的天数：,Type:=1)IfStrDate=FalseThenExitSubMsgBoxStrDate&天后的日期是&DateAdd(d,StrDate,Date)EndSub86119-6格式化时间和日期SubTimeDateFormat()DimStrAsStringStr=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)MsgBoxStrEndSub范例120使用字符串处理函数SubStrFunctions()DimStrAsStringStr=UseStringFunctionsMsgBox原始字符串：&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()DimrAsIntegerDimrngAsRangeDimYnumberAsStringDimNnumberAsStringr=Cells(Rows.Count,1).End(xlUp).RowForEachrngInRange(A1:A&r)IfIsNumeric(rng)ThenYnumber=Ynumber&rng.Address(0,0)&vbTab&rng&vbCrLfElseNnumber=Nnumber&rng.Address(0,0)&vbTab&rng&vbCrLf87EndIfNextMsgBox数值单元格：&vbCrLf&Ynumber&vbCrLf_&非数值单元格：&vbCrLf&NnumberEndSub范例122自定义数值格式SubCustomDigitalFormat()DimMyNumericAsDoubleDimStrAsStringMyNumeric=123456789Str=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))MsgBoxStrEndSub范例123四舍五入运算SubRounding()MsgBoxRound(4.56789,2)EndSubSubAmendmentsRound()MsgBoxRound(2.5+0.0000001)EndSubSubSheetsRound()MsgBoxApplication.Round(2.5,0)EndSub范例124使用Array函数创建数组OptionBase1SubMyarr()DimarrAsVariantDimiAsIntegerarr=Array(王晓明,吴胜玉,周志国,曹武伟,张新发,卓雪梅,沈煜婷,88丁林平)Fori=LBound(arr)ToUBound(arr)Cells(i,1)=arr(i)NextEndSub范例125将字符串按指定的分隔符分开SubSplitarr()DimArrAsVariantArr=Split(Cells(1,2),,)Cells(1,1).Resize(UBound(Arr)+1,1)=Application.Transpose(Arr)EndSub范例126使用动态数组去除重复值SubSplitarr()DimSplarr()AsStringDimArr()AsStringDimTemp()AsStringDimrAsIntegerDimiAsIntegerOnErrorResumeNextSplarr=Split(Range(B1),,)Fori=0ToUBound(Splarr)Temp=Filter(Arr,Splarr(i))IfUBound(Temp)0Thenr=r+1ReDimPreserveArr(1Tor)Arr(r)=Splarr(i)EndIfNextRange(A1).Resize(r,1)=Application.Transpose(Arr)EndSub范例127调用工作表函数127-1使用Sum函数求和SubSumCell()89DimrAsIntegerDimrngAsRangeDimDsumAsDoubler=Cells(Rows.Count,1).End(xlUp).RowSetrng=Range(A1:F&r)Dsum=Application.WorksheetFunction.Sum(rng)MsgBoxrng.Address(0,0)&单元格的和为&DsumEndSub127-2查找工作表中最大、最小值SubFindMaxAndMin()DimrAsIntegerDimRngAsRange,MyRngAsRangeDimMaxCountAsInteger,MainCountAsIntegerDimMymaxAsDouble,MyminAsDoubler=Cells(Rows.Count,1).End(xlUp).RowSetMyRng=Range(A1:J&r)ForEachRngInMyRngIfRng.Value=WorksheetFunction.max(MyRng)ThenRng.Interior.ColorIndex=3MaxCount=MaxCount+1Mymax=Rng.ValueElseIfRng.Value=WorksheetFunction.min(MyRng)ThenRng.Interior.ColorIndex=5MainCount=MainCount+1Mymin=Rng.ValueElseRng.Interior.ColorIndex=0EndIfNextMsgBox最大值是：&Mymax&，共有&MaxCount&个。_&Chr(13)&最小值是：&Mymin&，共有&MainCount&个。EndSub127-3不重复值的录入PrivateSubWorksheet_Change(ByValTargetAsRange)WithTargetIf.Column1Or.Count1ThenExitSubIfWorksheetFunction.CountIf(Range(A:A),.Value)1Then.SelectMsgBox不能输入重复的数据!,64Application.EnableEvents=False.Value=90Application.EnableEvents=TrueEndIfEndWithEndSub范例128个人所得税自定义函数PublicFunctionPITax(Income,OptionalThreshold)AsDoubleDimRateAsDoubleDimDeductionAsDoubleDimTaxliabilityAsDoubleIfIsMissing(Threshold)ThenThreshold=2000Taxliability=Income-ThresholdSelectCaseTaxliabilityCase0To500Rate=0.05Deduction=0Case500.01To2000Rate=0.1Deduction=25Case2000.01To5000Rate=0.15Deduction=125Case5000.01To20000Rate=0.2Deduction=375Case20000.01To40000Rate=0.25Deduction=1375Case40000.01To60000Rate=0.3Deduction=3375Case60000.01To80000Rate=0.35Deduction=6375Case80000.01To10000Rate=0.4Deduction=10375CaseElseRate=0.45Deduction=15375EndSelectIfTaxliability=0ThenPITax=091ElsePITax=Application.Round(Taxliability*Rate-Deduction,2)EndIfEndFunction范例129人民币大写函数PublicFunctionYuanCapital(Amountin)YuanCapital=Replace(Application.Text(Round(Amountin+0.00000001,2),[DBnum2])