vb自定义函数.docx
《vb自定义函数.docx》由会员分享，可在线阅读，更多相关《vb自定义函数.docx（21页珍藏版）》请在冰豆网上搜索。
vb自定义函数
vb自定义函数
自定义函数功能
自定义函数取值范围如何设定
my:
我现在在excel中用加载宏建立一个自己用的函数，不过我碰到一个问题，我要输入一个范围的参数，但不知道怎么样赋给函数。
function（colorsinteger，rg1sstring）sdouble
…………
forechcinrnge（rg1）.cells
…………
next
…………
endfunction
我现在要把选择的范围如1:
5、1:
E1、1:
E5这三中情况中的一种赋值给rg1,我用string好像不行，不知道该如何设置该参数的值
相当于VLOOKUP吧，查询某一值第num次出现的值
my:
作用说明：
相当于VLOOKUP吧，查询某一值第num次出现的值
参数说明：
Vlue1：
查询引用的数值
Rnge1：
查询区域
num：
指定查询第几次出现
Col：
返回值,相对引用区域,相对引用列的右数第Col列
[Copytoclipbord]CODE:
FunctionMyFind（Vlue1,ByVlRnge1sRnge,ByVlnumsInteger,ByVlColsInteger）
IfVlue1=""Then
返回指定列数的列标
my:
返回指定列数的列标
'pureNum为1-256之间的整数
[Copytoclipbord]CODE:
PublicFunctionNumToChr（PureNumsInteger）sString
IfPureNumMod26=0Then
NumToChr=VB.IIf（PureNum\26=1,"",VB.Chr（PureNum\26+63））&"Z"
Else
IfPureNum0
FoundPos=VB.InStr（1,OriginlStr,SerchStr）
从右边开始查找指定字符在字符串中的位置
my:
从右边开始查找指定字符在字符串中的位置
PublicFunctionMyInStrRev（MinStrsString,SubStrsString）sInteger
DimCountersInteger
DimSuccesssBoolen
IfVB.Len（MinStr）8Then
日期格式="日期位数不对"
ExitFunction
EndIf
OnErrorG
工龄计算：
my:
工龄计算：
FunctionElpsed（StrtDtesDte,EndDtesDte,ReturnTypesInteger）
DimStrtYersInteger'定义变量用以参数中开始日期的计算
DimStrtMonthsInteger
DimStrtDysInteger
DimEndYersInteger'定义变量用以参数中结束日期的计算
DimEndMonthsInteger
DimEndDy
计算日期差，除去星期六、星期日的自定义函数
my:
Functiondydif（xsRnge,ysRnge）
Dimdte1,dte2sDte
dte1=x
dte2=y
dif=0
Do
If（dte1>=dte2）Then
ExitDo
EndIf
dte1=dte1+1
t1=Weekdy（dte1）
If（t1999999999999999#Then:
DXie="数字超出转换范围!
!
RM币大小写转换函数
my:
FunctionNtoC（ByVln）sString'nsCurrency
ConstcNumsString="零壹贰叁肆伍陆柒捌玖-万仟佰拾亿仟佰拾万仟佰拾元角分"
ConstcChsString="零仟零佰零拾零零零零零亿零万零元亿万零角零分零整-零零零零零亿万元亿零整整"
DimsNumsString
DimisLong
If（n0）nd（bs（n）5000
tx=i*0.2-375
CseIs>2000
tx=i*0.15-125
CseIs>500
tx=i*0.1-25
CseIs>0
tx=i*0.05
18位身份证最后一位有效性验证
my:
'18位身份证最后一位有效性验证
FunctionisTrue（bCodesString）sString
Dimwi（1To17）sInteger
Dimi（1To11）sString
wi
（1）=7
wi
（2）=9
wi（3）=10
wi（4）=5
wi（5）=8
wi（6）=4
wi（7）=2
wi（8）=1
wi（9）=6
wi（10）=3
wi（11）=7
计算符合mturitycondition的拆解金额
my:
计算符合mturitycondition的拆解金额
主管让中午吃饭前把过去两个月里的拆解合同符合到期条件的金额换算成RM币后加总，一气之下写的（资本主义灭绝人性！
）。
有两长表，若干个nme。
希望对那些在银行的同学有用。
。
PublicFunctionLibToHo（dReportDtesDte,dbUSD2CNYsDouble,_dbHKD2CNYsDouble）sDouble
DimEntryNumsInteger
相当于多个vlookup函数相加，
my:
Functionvlookupmore（lookup_vlue,delimiter,dt_type,tble_rry,col_index_num）
Withppliction.Cller
IfNotmentIsNothingThenment.Delete
kmrr=split（lookup_vlue,delimiter）
ForEchperkmInkmrr
推断表是否存在的函数
my:
推断表是否存在的函数：
PublicFnctionIsSheetExist（wbsWorkBook,shtsString）sboolen
onerrorgotoErrISE
dimssstring
s=wb.worksheets（sht）.nme
IsSheetExist=True
ErrISE:
IsSheetExist=Flse
endfunction
我这个是角度转弧度的，以供大家参考
my:
我这个是角度转弧度的，以供大家参考
PublicConstpi=3.1415926535
PublicFunctionhd（dfmsSingle）sDouble
DimdsInteger
DimfsSingle
DimmsSingle
'分别取出输入度数的度、分、秒
d=Fix（dfm）
f=Fix（（dfm-d）*100）
m=（（dfm-d）*100-f）
Iff>=60Orm>=60Then
比较相同的字符串
my:
比较相同的字符串
FunctionFindExistCount（rngSourcesRnge,rngTrgetsRnge）sLong
DimlngCountsLong
DimrgsRnge
DimrngFindsRnge
ForEchrgInrngTrget
SetrngFind=rngSource.Find（rg.Text）
IfNot
對選定的陣列進行排序
my:
對選定的陣列進行排序
SubSORTX（）
DimXX（）sVrint
DimddressExcel.Rnge
DimRecordsLong
ddre=ctiveWindow.RngeSelection.ddress
WithRnge（ddre）
SRow=.Row'陣列起始列
CRow=.Rows.Count'陣列總列數
TRow=SRow
取得指定月份天數
my:
取得指定月份天數
PublicFunctionMDy（OptionlXDtesVrint=0）sInteger
IfIsDte（XDte）Then
MDy=Dy（DteSeril（Yer（XDte）,Month（XDte）+1,0））
Else
MDy=0
EndIf
EndFunction
排序工作表活頁薄
my:
排序工作表活頁薄
PrivteFunctionSort_Sheets（）
DimsCountsInteger,IsInteger,RsInteger
ReDimN（0）sString
sCount=Sheets.Count
ForI=1TosCount
ReDimPreserveN（I）sString
N（I）=Sheets（I）.Nme
Next
ForI=1TosCount-1
統計陣列中非重復數據個數
my:
統計陣列中非重復數據個數
PublicFunctionNumberCount（）sLong
DimSeRngesRnge
DimNxsRnge
DimNosDouble
SetSeRnge=Rnge（Selection.ddress）
ForEchNxInSeRnge
No=WorksheetFunction.CountIf（SeRnge,Nx）
If
摘取子字符串自定义函数
my:
摘取子字符串自定义函数
'自定义摘取子字符串函数，第一参数：
StrR为引用单元格，第二参数StrH为分割字符，
'第三参数I为摘取第几个子字符串
FunctionSsplit（StrRsRnge,StrHsString,IsInteger）sString
Ssplit=Split（ppliction.Trim（StrR）,StrH,-1）（I-1）
EndFunction
根据列表返回列序号
my:
我也来个简单的自定义函数，根据列表返回列序号，能否加一句排错功能，当输入参数有误时，显示参数有误？
Functioncolnumber（collphsString）sInteger
colnumber=Cells（1,collph）.Column
EndFunction
另大家能否解释一下这个函数
FunctionColLetter（colnumbersInteger）sString
OnErrorGoToErrorhndler
C
查找某值在某区域第n次出现时对应列的值
my:
模仿linlq986版主编的一个查找某值在某区域第n次出现时对应列的值
FunctionMyFind（rng,regionsRnge,countersInteger,ColsInteger）
'rng为要查找的值
'region为目标值所在的区域
'counter为rng第n次出现
'col为相对于region列的第几列
Dimrng0sRnge
Dimcounter0sInteger
'统计rng在region中有多少个，当counter大于查找值在
刪除當前工作表中的全部超連接。
?
my:
'刪除當前工作表中的全部超連接。
PublicFunctionPerLinks（）
DimNxsHyperlink
ForEchNxInXX:
//.docsj/doc/4dd947150b4e767f5cfce9d.htmledRnge.Hyperlinks
Nx.Delete
Next
EndFunction
取得相近數據
my:
取得相近數據
Subtet（）
DimtempsString
DimMyrry（11）
ForI=0To11
Myrry（I）=I
Next
hh="9"
temp=Myrry（0）
ForI=1To11
Ifbs（hh-Myrry（I））1Then
Txl.Font.ColorIndex=3
字符型轉數字型（快捷鍵F7）
my:
字符型轉數字型（快捷鍵F7）
PrivteFunctionTxtCDt（）
DimSelsRnge
DimTRowsLong,BRowsLong
DimLCousLong,RCousLong
SetSel=Rnge（Selection.ddress）
TRow=Sel.Row
BRow=TRow+Sel.Rows.Count-1
LCou=Sel.Column
RCo
最新自制函数：
小写RM币转大写RM币，附详细解释
my:
最新自制函数：
小写RM币转大写RM币，附详细解释。
FunctionDXRMB（ByVlnumsString）sString
DimNumV
DimHzStrsString,NumssString
NumV=Vl（num）'
IfNumV0OrStrt0Then
Text=Left（Field,Number-1）
Strt=Number
列出指定路徑下人
所有文件
my:
列出指定路徑下人所有文件
PublicFunctionFileDir（ByVlPth$）
DimvDirNmesString,LstDirsString,FullNmesString
IfRight（Pth$,1）-1Then_
I.Visible=-1
Next
EndSub
刪除自定義名稱
my:
刪除自定義名稱
刪除單無格自定義名稱
SubDeleteNme（）
ForEchIInXX:
//.docsj/doc/4dd947150b4e767f5cfce9d.htmls
XX:
//.docsj/doc/4dd947150b4e767f5cfce9d.htmls（XX:
//.docsj/doc/4dd947150b4e767f5cfce9d.html）.Delete
Next
EndSub
從文件路徑中取得文件名
my:
從文件路徑中取得文件名
FunctionFileNme（FullNmesVrint）sString
DimX%
FileNme$=FullNme
X%=InStr（FullNme,"\"）
DoWhileX%
Ct%=X%
X%=InStr（Ct%+1,FullNme,"\"）
Loop
IfCt%>0ThenFileNme$=Mid$（FullNme,Ct%+1）
E
取得一個文件的擴展名
my:
取得一個文件的擴展名。
FunctionExtension（FullNmesVrint）sString
DimX%
Extension$=FullNme
X%=InStr（FullNme,"\"）
DoWhileX%
Ct%=X%
X%=InStr（Ct%+1,FullNme,"\"）
Loop
IfCt%>0ThenExtension=Mid$（FullNme,Ct%+1）
取得一個文件的路徑
my:
取得一個文件的路徑
FunctionFilePth（FullNmesVrint）sString
DimX%,Ct%
FilePth$=FullNme
X%=InStr（FullNme,"\"）
DoWhileX%
IfX%>0ThenFilePth$=Left$（FullNme,X%）
X%=InStr（X%+1,FullNme,"\"）
Loop
EndFunction
十進制轉二進制
my:
十進制轉二進制
PublicFunctiondec2bin（mynumsVrint）sString
DimloopcountersInteger
Ifmynum>=2^31Then
dec2bin="Toobig"
ExitFunction
EndIf
Do
If（mynumnd2^loopcounter）=2^loopcounterThen
dec2bin="1"&dec
檢查一個陣列是否為空。
my:
檢查一個陣列是否為空。
PublicFunctionCheckrry（rryNmesVrint,OptionlComsInteger=0）sVrint
OnErrorGoToEr
SelectCseCom
Cse0
Do
Ne=Ne+1
XT=UBound（rryNme,Ne）
Loop
CseElse
Checkrry=UBound（
字母欄名轉數字欄名
my:
字母欄名轉數字欄名
FunctionColumnN（bcsString）sLong
bc=UCse（bc）
SelectCseLen（bc）
Cse1
ColumnN=sc（bc）-64
Cse2
ColumnN=（sc（Left（bc,1））-64）*26+sc（Right（bc,1））-64
EndSelect
EndFunction
數字欄名轉文字欄名
my:
數字欄名轉文字欄名
FunctionColumnT（ColumsInteger）sString
SelectCseColum
Cse1To26
ColumTex=Chr（64+Colum）
Cse27To256
ColumTex=Chr（64+（Colum\26））&Chr（64+（ColumMod26））
EndSelect
EndFunction
判斷一件文件夾中是否還有子目錄
my:
判斷一件文件夾中是否還有子目錄
FunctionCheckDirectory（sPthsString）sBoolen
IfRight（sPth,1）""
IfGetttr（sPth&sDir）ndvbDire
判斷一個文件是否在使用中
my:
'判斷一個文件是否在使用中
FunctionIsOpen（sFilesString）sBoolen
DimfFilesInteger
fFile=FreeFile（）
OnErrorGoToErrOpen
OpensFileForBinryLockRedWritesfFile
ClosefFile
ExitFunction
ErrOpen:
IfErr.Number
列出檔案詳細
g）sString
DimvrVrsVrint
vrVr=Split（fullNme,"\"）
vrVr（UBound（vrVr））=""
getPth=Join（vrVr,"\"）
EndFunction
取得一個文件的路徑3
FunctionthePth（fullNmesString）sString
thePth
取得ctivecell的栏名
my:
取得ctivecell的栏名
FunctionchrCol（myCellsRnge）sString
chrCol=Split（Split（myCell.ddress,":
"）（0）,"$"）
（1）
EndFunction
取得單元格中指定字符前的字符
my:
取得單元格中指定字符前的字符
PublicFunctionxLeft（RegsRnge,SpcesString）sVrint
DimXsInteger
X=InStr（Reg.Vlue,Spce）
IfX0Then
Reg.Chrcters（strt:
=1,Length:
=X）.Font.ColorIndex=3
Else
xLeft=Reg.Vlue
EndIf
EndFu
根据数字返回对应的字母列号
my:
相同功能的函数已有不少，不过，多一个不多吧！
'根据数字返回对应的字母列号
'n必须介于1到256之间
[Copytoclipbord]CODE:
Functionnum2letter（nsInteger）sString
Ifn>=1ndn=sc（"啊"）ndsc（t1）0Then
I=I+1
選取當前工作表中公式出錯的單元格﹐關返回出錯個數
my:
選取當前工作表中公式出錯的單元格﹐關返回出錯個數。
PublicF
unctionFormulErrors（）sLong
IfMsgBox（"Doyouwntselectcellswithnerrorintheirformul?
",_
vbQuestion+vbOKCncel,T）=vbCncelThenExitFunction
OnErrorGoToEr:
Cells.SpecilCel
將工作表中最后一列作為頁腳列印在每一面頁尾
my:
PublicSubPrin（）
'獲取總頁數
IfExecuteExcel4Mcro（"Get.Document（50）"）>1Then
'獲取每頁行數
I=ppliction.ExecuteExcel4Mcro（"INDEX（GET.DOCUMENT（64）,1）"）-2
X=I+1
L=Rnge（"65536"）.End（xlUp）.Row'總行數
ForT=2Toppl
獲取vbproject引用項目
my:
獲取vbproject引用項目
[Copytoclipbord]CODE:
SubListReferences（）
ForEchRefInThisWorkbook.VBProject.References
i=i+1
Cells（i,1）=XX:
//.docsj/doc/4dd947150b4e767f5cfce9d.html
Cells（i,2）=
升级会员 