VBA自定义函数大全.docx
- 文档编号:11239264
- 上传时间:2023-02-26
- 格式:DOCX
- 页数:223
- 大小:82.84KB
VBA自定义函数大全.docx
《VBA自定义函数大全.docx》由会员分享,可在线阅读,更多相关《VBA自定义函数大全.docx(223页珍藏版)》请在冰豆网上搜索。
VBA自定义函数大全
VBA自定义函数大全
龙族联盟论坛shcnmartin收集整理
'################################################################
'1.函数作用:
返回Column英文字
'################################################################
FunctionColLetter(ColNumberAsInteger)AsString
OnErrorGoToErrorhandler
ColLetter=Left(Cells(1,ColNumber).Address(0,0),1-(ColNumber>26))
ExitFunction
Errorhandler:
MsgBox"Errorencountered,pleasere-enter"
EndFunction
'################################################################
'2.函数作用:
查询某一值第num次出现的值
'参数说明:
Value1:
查询引用的数值;
'Range1:
查询区域;
'num:
指定查询第几次出现;
'Col:
返回值,相对引用区域,相对引用列的右数第Col列
'################################################################
FunctionMyFind(Value1,ByValRange1AsRange,ByValnumAsInteger,ByValColAsInteger)
IfValue1=""ThenExitFunction
IfRange1.Columns.Count>1ThenExitFunction
ForEachDInRange1
IfD.Value=Value1Then
c=c+1
Ifc=numThen
v1=D(1,Col)
ExitFor
EndIf
ElseIfIsEmpty(D)Then
ExitFor
EndIf
Next
Ifv1=""Thenv1="not"
MyFind=v1
EndFunction
'################################################################
'3.函数作用:
返回当个人工资薪金所得为2000元(起征点为850元)时的应纳个人所得税税额
'语法:
Grsds(bsc,mysala)
'参数说明:
bsc:
必选项,为起征点,包括税法规定的工资基数800元加上允许税前扣除的合理费用;
'mysala:
必选项,为人个工资薪金所得。
'示例:
Grsds(850,20000)=
'################################################################
FunctionGrsds(bscAsDouble,mysalaAsDouble)AsDouble
'bsc为起征点加上允许税前扣除的合理费用,mysala为工资薪金所得
OnErrorGoToGrsds_err
SelectCasemysala
CaseIs<=bsc
Grsds=0
CaseIs<=bsc+500
Grsds=Application.WorksheetFunction.Round((mysala-bsc)*0.05,2)
CaseIs<=bsc+2000
Grsds=Application.WorksheetFunction.Round((mysala-bsc)*0.1-25,2)
CaseIs<=bsc+5000
Grsds=Application.WorksheetFunction.Round((mysala-bsc)*0.15-125,2)
CaseIs<=bsc+20000
Grsds=Application.WorksheetFunction.Round((mysala-bsc)*0.2-375,2)
CaseIs<=bsc+40000
Grsds=Application.WorksheetFunction.Round((mysala-bsc)*0.25-1375,2)
CaseIs<=bsc+60000
Grsds=Application.WorksheetFunction.Round((mysala-bsc)*0.3-3375,2)
CaseIs<=bsc+80000
Grsds=Application.WorksheetFunction.Round((mysala-bsc)*0.35-6375,2)
CaseIs<=bsc+100000
Grsds=Application.WorksheetFunction.Round((mysala-bsc)*0.4-10375,2)
CaseElse
Grsds=Application.WorksheetFunction.Round((mysala-bsc)*0.45-15375,2)
EndSelect
Grsds_Exit:
ExitFunction
Grsds_err:
MsgBoxErr.Number&":
"&Err.Description
ResumeGrsds_Exit
EndFunction
'################################################################
'4.函数作用:
从形如"123545ABCDE"的字符串中取出数字
'################################################################
Functionmyvalue(mystringAsString)AsDouble
myvalue=Val(mystring)
EndFunction
'################################################################
'5.函数作用:
从形如"ABCD12455EDF"的字符串中取出数字
'################################################################
Functionmydata(mystringAsString)AsDouble
DimiAsInteger
i=1
DoUntilVal(Mid(mystring,i,1))>0
i=i+1
Loop
mydata=Val(Mid(mystring,i,Len(mystring)-i+1))
EndFunction
'################################################################
'6.函数作用:
按SplitType取得RangeName串值中的起始位置
'################################################################
'1:
单元格,2:
行号,3:
列号,4:
范围
PublicConstSINGLE_CELL=1
PublicConstROW_NUM=2
PublicConstCOL_NUM=3
PublicConstRANGE_ALL=4
PublicFunctionSplitRangeName(RangeNameAsString,SplitTypeAsInteger)AsString
IfVBA.Len(RangeName)<3Then
ExitFunction
Else
RangeName=VBA.Right(RangeName,VBA.Len(RangeName)-VBA.InStr(1,RangeName,"!
")-1)
IfVBA.InStr(1,RangeName,":
")>0ThenRangeName=VBA.Left(RangeName,VBA.InStr(1,RangeName,":
")-1)
SelectCaseSplitType
CaseSINGLE_CELL
IfVBA.InStr(1,RangeName,":
")<>0Then
SplitRangeName="$"&VBA.Left(RangeName,VBA.InStr(1,RangeName,":
")-1)
Else
SplitRangeName="$"&RangeName
EndIf
CaseROW_NUM
SplitRangeName=VBA.IIf(VBA.InStr(1,RangeName,"$")>0,VBA.Right(RangeName,VBA.Len(RangeName)-VBA.InStr(1,RangeName,"$")),RangeName)
IfNotIsNumeric(SplitRangeName)Then
SplitRangeName=""
MsgBox"",vbInformation,""
EndIf
CaseCOL_NUM
IfVBA.InStr(1,RangeName,"$")>0Then
SplitRangeName=VBA.Left(RangeName,VBA.InStr(1,RangeName,"$")-1)
Else
SplitRangeName=RangeName
EndIf
IfIsNumeric(SplitRangeName)Then
SplitRangeName=""
MsgBox"",vbInformation,""
EndIf
CaseRANGE_ALL
SplitRangeName="$"&RangeName
EndSelect
EndIf
EndFunction
'################################################################
'7.函数作用:
将金额数字转成中文大写
'################################################################
FunctionMoney(NumberAsCurrency)
Dimi,j,k,m,lengAsInteger'计数器
DimZeroAsInteger'连续零标识
DimTnumberAsString'储存数字字符串,计算数组长度
DimNum()AsString'定义数组
DimNum1(3)AsString'存储万元以下数字
DimNum2
(1)AsString'储存拆分后的数字
DimCha(8),Cha1(9),Cha2(4)AsString'储存转化后的汉字
DimZchaAsString'连接后的字符串
DimFlag,Flag1AsBoolean'正负标志
Flag=True
Flag1=False
Zero=0
'如果大于一亿,则不处理
If(Number>99999999)Or(Number<-99999999)Then
MsgBox("Sorry,数据超过一亿,暂不处理。
")
MsgBox("顺便问一下,你真有那么多钱吗?
")
Money="Sorry!
"
Else
If(Number=0)Then
Money="零元整"
Else
'*****将负数数字转化正数并更改标识*****
If(Number<0)Then
Number=Number*(-1)
Flag=False
EndIf
'*****小数点后超过两位,则截断*****
If(((Number-Int(Number))*100-Int((Number-Int(Number))*100))>0)Then
Tnumber=CStr(Int(Number*100)/100)
Else
Tnumber=CStr(Number)
EndIf
'*****处理四舍五入*****
If(((Number-Int(Number))*100-Int((Number-Int(Number))*100))>=0.5)Then
Tnumber=CStr((CCur(Tnumber))+0.01)
EndIf
Number=CCur(Tnumber)
'*****重新分配数组空间*****
ReDimNum(Len(Tnumber)-1)AsString
'*****将字符串分开存储至数组中*****
Fori=0ToLen(Tnumber)-1
Num(i)=Mid(Tnumber,i+1,1)
Nexti
'*****定义所需字符*****
DimM1,M2
M1=Array("零","壹","贰","叁","肆","伍","陆","柒","捌","玖")
M2=Array("","拾","佰","仟","万","亿")
'*****处理小于一元金额*****
'*****小数点后一位,则*****
If((Number-Int(Number)>0)And((Number*100-Int(Number)*100)Mod10)=0)Then
i=i-1
Num2(0)=Num(i)
Num(i)=""
i=i-1
Num(i)=""
i=i-1
Cha2(0)=M1(CByte(Num2(0)))
Cha2
(1)="角"
Cha2
(2)="整"
Else
'*****小数点后两位则*****
If((Number-Int(Number)>0))Then
i=i-1
Num2
(1)=Num(i)
Num2(0)=Num(i-1)
Num(i)=""
i=i-1
Num(i)=""
i=i-1
Num(i)=""
i=i-1
Cha2(0)=M1(CByte(Num2(0)))
Cha2
(1)="角"
Cha2
(2)=M1(CByte(Num2
(1)))
Cha2(3)="分"
EndIf
EndIf
'*****分解大于一万的整数部分*****
If(Int(Number)>9999)Then
If(Cha2(0)<>"")Then
i=i+1
EndIf
Forj=3To0Step-1
Num1(j)=Num(i-1)
Num(i-1)=""
i=i-1
Nextj
Else
If(Cha2(0)<>"")Then
i=i+1
EndIf
Forj=0Toi-1
Num1(j)=Num(j)
Num(j)=""
Nextj
EndIf
'*****转换万元以上数字*****
If(Num(0)<>"")Then
leng=i
j=0
Fork=0Toleng-1
If(Num(k)="0")Then
Zero=Zero+1
Form=1To5
If(Cha(j-1)=M2(m))Then
Flag1=True
EndIf
Nextm
If((Zero=1)And(Flag1=False))Then
Cha(j)=M1(CByte(Num(k)))
EndIf
If(Zero=1)Then
j=j+1
EndIf
Else
If(Num(k)<>"")Then
If(Zero>0)Then
Cha(j-1)="零"
EndIf
Cha(j)=M1(CByte(Num(k)))
EndIf
j=j+1
EndIf
If(Num(k)="0")Then
i=i-1
Else
Cha(j)=M2(i-1)
j=j+1
i=i-1
Zero=0
EndIf
Nextk
Cha(j-1)="万"
Zero=0
EndIf
'*****转换万元以下数字*****
If(Num1(0)<>"")Then
j=0
Flag1=False
leng=3
While(Num1(leng)="")
leng=leng-1
Wend
i=leng+1
Fork=0Toleng
If(Num1(k)<>"")Then
If(Num1(k)="0")Then
Zero=Zero+1
Form=1To5
If(j<>0)Then
If(Cha1(j-1)=M2(m))Then
Flag1=True
EndIf
EndIf
Nextm
If((Zero=1)And(Flag1=False))Then
Cha1(j)=M1(CByte(Num1(k)))
EndIf
If(Zero=1)Then
j=j+1
EndIf
Else
If(Num1(k)<>"")Then
If(Zero>0)Then
Cha1(j-1)="零"
EndIf
Cha1(j)=M1(CByte(Num1(k)))
EndIf
j=j+1
EndIf
If(Num1(k)="0")Then
i=i-1
Else
Cha1(j)=M2(i-1)
j=j+1
i=i-1
Zero=0
EndIf
EndIf
Nextk
Cha1(j-1)="元"
If(Cha2(0)="")Then
Cha1(j)="整"
EndIf
EndIf
'*****连接字符串*****
j=0
While(Cha(j)<>"")
Zcha=Zcha&Cha(j)
j=j+1
Wend
j=0
While(Cha1(j)<>"")
Zcha=Zcha&Cha1(j)
j=j+1
Wend
j=0
While(Cha2(j)<>"")
Zcha=Zcha&Cha2(j)
j=j+1
Wend
'*****最终显示*****
If(Flag)Then
Money=Zcha
Else
Money="负"&Zcha
EndIf
EndIf
EndIf
EndFunction
'################################################################
'8.函数作用:
计算某种税金
'################################################################
PublicFunction税(fa)
Dimx
If(fa-800)>0And(fa-800)<500Then
x=(fa-800)*0.05
税=x
ElseIf(fa-800)>=500And(fa-800)<2000Then
x=(fa-800)*0.1-25
税=x
ElseIf(fa-800)>=2000And(fa-800)<5000Then
x=(fa-800)*0.15-125
税=x
ElseIf(fa-800)>=5000And(fa-800)<20000Then
x=(fa-800)*0.2-375
税=x
ElseIf(fa-800)>=20000And(fa-800)<40000Then
x=(fa-800)*0.25-1375
税=x
ElseIf(fa-800)>=40000And(fa-800)<60000Then
x=(fa-800)*0.3-3375
税=x
ElseIf(fa-800)>=60000And(fa-800)<80000Then
x=(fa-800)*0.35-6375
税=x
ElseIf(fa-800)>=80000And(fa-800)<100000Then
x=(fa-800)*0.4-10375
税=x
ElseIf(fa-800)>=100000Then
x=(fa-800)*0.45-15375
税=x
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- VBA 自定义 函数 大全