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
升级会员 