第8章函数的使用代码超实用VBAWord文档下载推荐.docx
- 文档编号:19225584
- 上传时间:2023-01-04
- 格式:DOCX
- 页数:12
- 大小:18.48KB
第8章函数的使用代码超实用VBAWord文档下载推荐.docx
《第8章函数的使用代码超实用VBAWord文档下载推荐.docx》由会员分享,可在线阅读,更多相关《第8章函数的使用代码超实用VBAWord文档下载推荐.docx(12页珍藏版)》请在冰豆网上搜索。
IfLen(StrDate)=0ThenExitSub
IfIsDate(StrDate)Then
SelectCaseWeekday(StrDate,vbSunday)
CasevbSunday
Myweekday="
星期日"
CasevbMonday
星期一"
CasevbTuesday
星期二"
CasevbWednesday
星期三"
CasevbThursday
星期四"
CasevbFriday
星期五"
CasevbSaturday
星期六"
EndSelect
MsgBoxDateValue(StrDate)&
Myweekday
Else
请输入正确格式的日期!
EndIf
119-4计算两个日期的时间间隔
SubDateInterval()
Chr(13)&
距离今天有"
_
Abs(DateDiff("
d"
Date,StrDate))&
天"
119-5获得指定时间间隔的日期
SubMyDateAdd()
StrDate=Application.InputBox(Prompt:
="
请输入间隔的天数:
Type:
=1)
IfStrDate=FalseThenExitSub
MsgBoxStrDate&
天后的日期是"
DateAdd("
StrDate,Date)
119-6格式化时间和日期
SubTimeDateFormat()
DimStrAsString
Str=Format(Now,"
MediumTime"
Chr(13)_
Format(Now,"
LongTime"
ShortTime"
GeneralDate"
LongDate"
MediumDate"
ShortDate"
MsgBoxStr
范例120使用字符串处理函数
SubStrFunctions()
Str="
UseStringFunctions"
原始字符串:
Str&
字符串长度:
Len(Str)&
左边8个字符:
Left(Str,8)&
右边6个字符:
Right(Str,6)&
Str"
出现在字符串的第"
InStr(Str,"
位"
从左边第5个开始取6个字符:
Mid(Str,5,6)&
转换为大写:
UCase(Str)&
转换为小写:
LCase(Str)&
Chr(13)
范例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
Nnumber=Nnumber&
数值单元格:
vbCrLf&
Ynumber&
vbCrLf_
非数值单元格:
Nnumber
范例122自定义数值格式
SubCustomDigitalFormat()
DimMyNumericAsDouble
MyNumeric=123456789
Str=Format(MyNumeric,"
Format(MyNumeric,"
0%"
#,##0.00"
$#,##0.00"
Format(-(MyNumeric),"
¥#,##0.00;
(¥#,##0.00)"
范例123四舍五入运算
SubRounding()
MsgBoxRound(4.56789,2)
SubAmendmentsRound()
MsgBoxRound(2.5+0.0000001)
SubSheetsRound()
MsgBoxApplication.Round(2.5,0)
范例124使用Array函数创建数组
OptionBase1
SubMyarr()
DimarrAsVariant
arr=Array("
王晓明"
"
吴胜玉"
周志国"
曹武伟"
张新发"
卓雪梅"
沈煜婷"
丁林平"
Fori=LBound(arr)ToUBound(arr)
Cells(i,1)=arr(i)
范例125将字符串按指定的分隔符分开
SubSplitarr()
DimArrAsVariant
Arr=Split(Cells(1,2),"
"
Cells(1,1).Resize(UBound(Arr)+1,1)=Application.Transpose(Arr)
范例126使用动态数组去除重复值
DimSplarr()AsString
DimArr()AsString
DimTemp()AsString
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)
Range("
A1"
).Resize(r,1)=Application.Transpose(Arr)
范例127调用工作表函数
127-1使用Sum函数求和
SubSumCell()
DimDsumAsDouble
Setrng=Range("
F"
Dsum=Application.WorksheetFunction.Sum(rng)
MsgBoxrng.Address(0,0)&
单元格的和为"
Dsum
127-2查找工作表中最大、最小值
SubFindMaxAndMin()
DimRngAsRange,MyRngAsRange
DimMaxCountAsInteger,MainCountAsInteger
DimMymaxAsDouble,MyminAsDouble
SetMyRng=Range("
J"
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
Rng.Interior.ColorIndex=0
最大值是:
Mymax&
,共有"
MaxCount&
个。
最小值是:
Mymin&
MainCount&
127-3不重复值的录入
PrivateSubWorksheet_Change(ByValTargetAsRange)
WithTarget
If.Column<
>
1Or.Count>
1ThenExitSub
IfWorksheetFunction.CountIf(Range("
A:
),.Value)>
1Then
.Select
不能输入重复的数据!
64
Application.EnableEvents=False
.Value="
Application.EnableEvents=True
EndWith
范例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
IfTaxliability<
=0Then
PITax=0
PITax=Application.Round(Taxliability*Rate-Deduction,2)
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=Replace(Replace(Replace(Replace(YuanCapital,"
零元零角"
零元"
零角"
-"
负"
范例130判断工作表是否为空表
FunctionIsBlankSht(ShAsVariant)AsBoolean
IfTypeName(Sh)="
String"
ThenSetSh=Worksheets(Sh)
IfApplication.CountA(Sh.UsedRange.Cells)=0Then
IsBlankSht=True
SubDelBlankSht()
DimShAsWorksheet
ForEachShInThisWorkbook.Sheets
IfIsBlankSht(Sh)Then
Application.DisplayAlerts=False
Sh.Delete
Application.DisplayAlerts=True
SetSh=Nothing
范例131查找指定工作表
FunctionExistSh(ShAsString)AsBoolean
DimShtAsWorksheet
SetSht=Sheets(Sh)
IfErr=0ThenExistSh=True
SetSht=Nothing
SubNotSht()
DimShAsString
Sh=InputBox("
请输入工作表名称:
IfLen(Sh)>
IfNotExistSh(Sh)Then
对不起,"
Sh&
工作表不存在!
Sheets(Sh).Select
范例132查找指定工作簿
FunctionExistWorkbook(WbNameAsString)AsBoolean
DimWbAsWorkbook
SetWb=Workbooks(WbName)
IfErr=0ThenExistWorkbook=True
SetWb=Nothing
SubNotWorkbook()
DimWbAsString
Wb=InputBox("
请输入工作簿名称:
IfLen(Wb)>
IfNot(ExistWorkbook(Wb))Then
MsgBoxWb&
工作簿没有打开!
【代码解析】自定义ExistWorkbook函数判断指定名称的工作簿是否打开。
第5行代码,判断第4行代码是否出错,如果出错,则表示指定名称的工作簿没有打开,自定义ExistWorkbook函数返回False。
使用自定义ExistWorkbook函数可以判断指定名称的工作簿是否打开,范例代码如下:
#001SubNotWorkbook()
#002DimWbAsString
#003Wb=InputBox("
#004IfLen(Wb)>
#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
SubWinRARPath()
MsgBoxGetSetupPath("
WinRAR.exe"
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- 第8章 函数的使用代码超实用VBA 函数 使用 代码 实用 VBA