VBA自定义函数1
目 录
1.返回列标
2.返回列标2
3.查询某一值第num次出现的值
4.返回当个人所得税
5.从形如"123545ABCDE"的字符串中取出数字
6.从形如"ABCD12455EDF"的字符串中取出数字
7.按SplitType取得RangeName串值中的起始位置
8.将金额数字转成中文大写
9.计算某种税金
10.人民币大、小写转换
11.查汉字区位码
12.把公历转为农历
13.返回指定列数的列标
14.用指定字符替换某字符
15.从右边开始查找指定字符在字符串中的位置
16.从右边开始查找指定字符在字符串中的位置
17.计算工龄
18.计算日期差，除去星期六、星期日
19.将英文字反转的自定函数.
20.计算个人所得税
21.一个能计算是否有重复单元的函数
22.数字金额转中文大写
23.将数字转成英文
24.人民币大小写转换
25.获取区域颜色值
26.获取活动工作表名
27.获取最后一行行数
28.判断是否连接在线
29.币种转换
30.检验工作表是否有可打印内容
31.查找一字符串(withinstr)在另一字符串中(findstr1)中某一次(startnum)出现时的位置，返回零表示没找到。
32.在文件路径后面增加反斜杠符号
33.计算所得税
34.从工作表第一行的标题文字以数字形式返回所在列号
35.在多个工作表中查找一个范围内符合某个指定条件的项目对应指定范围加总求和
36.查找指定列名的列数
37.文字格式的时间(分：秒)转化为数字格式(秒)
38.将"hh：mm：ss"格式的时分秒数转换成秒数
39.金额中文大写转数字
40.把角度转为度秒分、弧度等显示
41.身份证号码侦测
42.显示公式
43.方便财务人员理帐查找
44.数值转换为字符地址
45.字符地址转换为数值
46.等待时间（以秒计算）
47.得到字符串实际的长度（以单字节记）
48.18位身份证最后一位有效性验证
49.计算符合maturity condition的拆解金额
50.对多个用同一分隔符分隔的待查找元素，逐一在表区域首列内搜索，将返回选定单元格的值相加
51.根据个人所得税（工资）反算工资数
52.判断工作表是否存在
53.角度转弧度
54.比较相同的字符串
55.对选定的数组进行排序
56.取得指定月份天数
57.排序工作表活页薄
58.统计数组中非重复数据个数
59.摘取子字符串
60.计算20000余个汉字的笔画
61.删除当前工作表中的全部超连接
62.取得相近数据
63.提取字符串中汉字
64.搜索重复数据(选定范围)
65.字符型转数字型
66.小写人民币转大写人民币
67.取得指定月份人星期天个数
68.侦测档案是否包含宏
69.获取循环参照单元格
70.创建桌面快捷方式
71.自动建立多级目录
72.统计经筛选后符合条件的记录条数
73.复制单元格列高与栏宽
74.取消隐藏工作表
75.删除单元格自定义名称
76.从文件路径中取得文件名
77.取得一个文件的扩展名
78.取得一个文件的路径
79.取得一个文件的路径2
80.取得一个文件的路径3
81.十进制转二进制
82.检查一个数组是否为空
83.字母栏名转数字栏名
84.数字栏名转文字栏名
85.判断一件活页夹中是否还有子目录
86.判断一个文件是否在使用中
87.列出档案详细摘要信息
88.获取菜单ID编号及名称列表
89.状态列动态显示文字
90.取得Activecell的栏名
91.取得单元格中指定字符前的字符
92.前单元格指定字符前的字符颜色改成红色
93.根据数字返回对应的字母列号
94.取工作表名字
95.取消所有隐藏的宏表
96.导出VBA Project代码
97.导入VBA Project代码
98.取得汉字拼音的第一个字母
99.获取两栏中相同的数据
100.选取当前工作表中公式出错的单元格﹐关返回出错个数
101.将工作表中最后一列作为页脚打印在每一面页尾
102.获取vbproject引用项目
103.移除Excel工作表中的外部数据连接
104.将选择定单元格作成镜像图片
105.反选择单元格中的数
106.在Excel中加入一个量度尺(以厘米为单位)
107.在Excel中加入一个量度尺(以寸为单位)
108.取得一个短文件名的长文件名
109.取得临时文件名
110.等用Shell调用的程序执行完成后再执行其它程序
111.将Mouse显示成动画
112.限制Mouse移动范围
113.取得当前激活窗品句柄及标题
114.取得屏幕分辨率
115.自动建立多级目录
116.将文件长度置零
117.读取WIN共享文件夹密码
118.取得预设的打印机及设置预设的打印机
119.获得当前操作系统的打印机个数及检测打印是否存在
120.枚举打印机名称清单
121.读取网络服务器当前时间
122.下载文件到指定目录
123.自动映射网络驱动器
124.自动断开网络驱动器
125.连接选定单元格中的内容
126.获取一个单元格中有指定字体颜色部份数据
127.对指定文件加XLS加密
128.选择指定范围内使用了填充颜色的单元格
129.在特定的区域内查找文本,返回值是包含查找文本的单元格
130.返回特定区域中最大值的地址
131.删除表格中使用范围内的所有空白单元格
132.返回数组中有多少个指定的字符串
133.返回当前工作表中引用了指定的单元的地址
134.获取Excel中字型列表
135.获取一个字符串中有多少个数字字符
136.在Excel中对多列进行填充
137.对选定的范围进行数据填充
138.VBA Project加密及解密
139.列出收藏夹中的网址
140.计算两个日期之间相隔的年份
141.从字符串提取纯数字
142.将一个数组按升序排列
143.将一个数组按降序排列
144.删除空白列
145.判断工作表是否为空白
146.将数据按类分到不同工作薄
147.单元格内数据排序
148.对多栏排序
149.返回计算公式的值
150.把第一列=某个值对应的第二列的内容连在一起，并用、隔开
151.取得系统使用模式
152.计算机注销、关机、重启
153.更改计算机名称
154.从n位开始取出字符串中的汉字、英文字母、数字
155.在指定列中寻找含有指定字符串的单元格，并将符合条件的单元格标为红色，并将对应的下一列单元格赋值为1
156.清除字符串中的空格
157.查找合并单元格位置
158.阴阳历转换和阴阳历生日
159.利用数组和Substitute来替换某字符
160.一键创建斜线表头
161.自动获取指定月的工作日
'################################################################
'1.函数作用：返回列标
'################################################################
Function ColLetter(ColNumber As Integer) As String
On Error GoTo Errorhandler
ColLetter = Left(Cells(1, ColNumber).Address(0, 0), 1 - (ColNumber > 26))
Exit Function
Errorhandler:
MsgBox "Error encountered, please re-enter "
End Function
'################################################################
'2.函数作用：返回列标2
'################################################################
Function ColIntToLetter(intCol As Integer) As String
''
Dim intPart As Integer
Dim intRemainder As Integer
If intCol > 255 Or intCol <= 0 Then
MsgBox ("The Wrong Column Number: " & CStr(intCol))
Exit Function
End If
intPart = intCol \ 26
intRemainder = intCol Mod 26
If intPart = 0 Then
ColIntToLetter = Chr(intCol + 64)
ElseIf intPart = 1 And intRemainder = 0 Then
ColIntToLetter = "Z"
ElseIf intRemainder = 0 Then
ColIntToLetter = Chr(intPart - 1 + 64) & "Z"
Else
ColIntToLetter = Chr(intPart + 64) & Chr(intRemainder + 64)
End If
End Function
'################################################################
'3.函数作用：查询某一值第num次出现的值
' 参数说明：Value1：查询引用的数值;
' Range1：查询区域;
' num：指定查询第几次出现;
' Col：返回值, 相对引用区域, 相对引用列的右数第Col列
'################################################################
Function MyFind(Value1, ByVal Range1 As Range, ByVal num As Integer, ByVal Col As Integer)
If Value1 = "" Then Exit Function
If Range1.Columns.Count > 1 Then Exit Function
For Each D In Range1
If D.Value = Value1 Then
c = c + 1
If c = num Then
v1 = D(1, Col)
Exit For
End If
ElseIf IsEmpty(D) Then
Exit For
End If
Next
If v1 = "" Then v1 = "not"
MyFind = v1
End Function
'################################################################
'4.函数作用：返回当个人所得税
' 语 法：Grsds(bsc, mysala)
' 参数说明：bsc: 必选项，为起征点，包括税法规定的工资基数800元加上允许税前扣除的合理费用;
' mysala: 必选项，为人个工资薪金所得。
' 示 例：Grsds(850, 20000) =
'################################################################
Function Grsds(bsc As Double, mysala As Double) As Double
''bsc为起征点加上允许税前扣除的合理费用,mysala为工资薪金所得
On Error GoTo Grsds_err
Select Case mysala
Case Is <= bsc
Grsds = 0
Case Is <= bsc + 500
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.05, 2)
Case Is <= bsc + 2000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.1 - 25, 2)
Case Is <= bsc + 5000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.15 - 125, 2)
Case Is <= bsc + 20000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.2 - 375, 2)
Case Is <= bsc + 40000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.25 - 1375, 2)
Case Is <= bsc + 60000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.3 - 3375, 2)
Case Is <= bsc + 80000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.35 - 6375, 2)
Case Is <= bsc + 100000
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.4 - 10375, 2)
Case Else
Grsds = Application.WorksheetFunction.Round((mysala - bsc) * 0.45 - 15375, 2)
End Select
Grsds_Exit:
Exit Function
Grsds_err:
MsgBox Err.Number & ":" & Err.Description
Resume Grsds_Exit
End Function
'################################################################
'5.函数作用：从形如"123545ABCDE"的字符串中取出数字
'################################################################
Function myvalue(mystring As String) As Double
myvalue = Val(mystring)
End Function
'################################################################
'6.函数作用：从形如"ABCD12455EDF"的字符串中取出数字
'################################################################
Function mydata(mystring As String) As Double
Dim i As Integer
i = 1
Do Until Val(Mid(mystring, i, 1)) > 0
i = i + 1
Loop
mydata = Val(Mid(mystring, i, Len(mystring) - i + 1))
End Function
'################################################################
'7.函数作用：按SplitType取得RangeName串值中的起始位置
'################################################################
'1:单元格，2:行号，3:列号，4:范围
Public Const SINGLE_CELL = 1
Public Const ROW_NUM = 2
Public Const COL_NUM = 3
Public Const RANGE_ALL = 4
Public Function SplitRangeName(RangeName As String, SplitType As Integer) As String
If VBA.Len(RangeName) < 3 Then
Exit Function
Else
RangeName = VBA.Right(RangeName, VBA.Len(RangeName) - VBA.InStr(1, RangeName, "!") - 1)
If VBA.InStr(1, RangeName, ":") > 0 Then RangeName = VBA.Left(RangeName, VBA.InStr(1, RangeName, ":") - 1)
Select Case SplitType
Case SINGLE_CELL
If VBA.InStr(1, RangeName, ":") <> 0 Then
SplitRangeName = "$" & VBA.Left(RangeName, VBA.InStr(1, RangeName, ":") - 1)
Else
SplitRangeName = "$" & RangeName
End If
Case ROW_NUM
SplitRangeName = VBA.IIf(VBA.InStr(1, RangeName, "$") > 0, VBA.Right(RangeName, VBA.Len(RangeName) - VBA.InStr(1, RangeName, "$")), RangeName)
If Not IsNumeric(SplitRangeName) Then
SplitRangeName = ""
MsgBox "", vbInformation, ""
End If
Case COL_NUM
If VBA.InStr(1, RangeName, "$") > 0 Then
SplitRangeName = VBA.Left(RangeName, VBA.InStr(1, RangeName, "$") - 1)
Else
SplitRangeName = RangeName
End If
If IsNumeric(SplitRangeName) Then
SplitRangeName = ""
MsgBox "", vbInformation, ""
End If
Case RANGE_ALL
SplitRangeName = "$" & RangeName
End Select
End If
End Function
'################################################################
'8.函数作用：将金额数字转成中文大写
'################################################################
Function Money(Number As Currency)
Dim i, j, k, m, leng As Integer ''计数器
Dim Zero As Integer ''连续零标识
Dim Tnumber As String ''储存数字字符串,计算数组长度
Dim Num() As String ''定义数组
Dim Num1(3) As String ''存储万元以下数字
Dim Num2(1) As String ''储存拆分后的数字
Dim Cha(8), Cha1(9), Cha2(4) As String ''储存转化后的汉字
Dim Zcha As String ''连接后的字符串
Dim Flag, Flag1 As Boolean ''正负标志
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
End If
''*****小数点后超过两位，则截断*****
If (((Number - Int(Number)) * 100 - Int((Number - Int(Number)) * 100)) > 0) Then
Tnumber = CStr(Int(Number * 100) / 100)
Else
Tnumber = CStr(Number)
End If
''*****处理四舍五入*****
If (((Number - Int(Number)) * 100 - Int((Number - Int(Number)) * 100)) >= 0.5) Then
Tnumber = CStr((CCur(Tnumber)) + 0.01)
End If
Number = CCur(Tnumber)
''*****重新分配数组空间*****
ReDim Num(Len(Tnumber) - 1) As String
''*****将字符串分开存储至数组中*****
For i = 0 To Len(Tnumber) - 1
Num(i) = Mid(Tnumber, i + 1, 1)
Next i
''*****定义所需字符*****
Dim M1, M2
M1 = Array("零", "壹", "贰", "叁", "肆", "伍", "陆", "柒", "捌", "玖")
M2 = Array("", "拾", "佰", "仟", "万", "亿")
''*****处理小于一元金额*****
''*****小数点后一位，则*****
If ((Number - Int(Number) > 0) And ((Number * 100 - Int(Number) * 100) Mod 10) = 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) = "分"
End If
End If
''*****分解大于一万的整数部分*****
If (Int(Number) > 9999) Then
If (Cha2(0) <> "") Then
i = i + 1
End If
For j = 3 To 0 Step -1
Num1(j) = Num(i - 1)
Num(i - 1) = ""
i = i - 1
Next j
Else
If (Cha2(0) <> "") Then
i = i + 1
End If
For j = 0 To i - 1
Num1(j) = Num(j)
Num(j) = ""
Next j
End If
''*****转换万元以上数字*****
If (Num(0) <> "") Then
leng = i
j = 0
For k = 0 To leng - 1
If (Num(k) = "0") Then
Zero = Zero + 1
For m = 1 To 5
If (Cha(j - 1) = M2(m)) Then
Flag1 = True
End If
Next m
If ((Zero = 1) And (Flag1 = False)) Then
Cha(j) = M1(CByte(Num(k)))
End If
If (Zero = 1) Then
j = j + 1
End If
Else
If (Num(k) <> "") Then
If (Zero > 0) Then
Cha(j - 1) = "零"
End If
Cha(j) = M1(CByte(Num(k)))
End If
j = j + 1
End If
If (Num(k) = "0") Then
i = i - 1
Else
Cha(j) = M2(i - 1)
j = j + 1
i = i - 1
Zero = 0
End If
Next k
Cha(j - 1) = "万"
Zero = 0
End If
''*****转换万元以下数字*****
If (Num1(0) <> "") Then
j = 0
Flag1 = False
leng = 3
While (Num1(leng) = "")
leng = leng - 1
Wend
i = leng + 1
For k = 0 To leng
If (Num1(k) <> "") Then
If (Num1(k) = "0") Then
Zero = Zero + 1
For m = 1 To 5
If (j <> 0) Then
If (Cha1(j - 1) = M2(m)) Then
Flag1 = True
End If
End If
Next m
If ((Zero = 1) And (Flag1 = False)) Then
Cha1(j) = M1(CByte(Num1(k)))
End If
If (Zero = 1) Then
j = j + 1
End If
Else
If (Num1(k) <> "") Then
If (Zero > 0) Then
Cha1(j - 1) = "零"
End If
Cha1(j) = M1(CByte(Num1(k)))
End If
j = j + 1
End If
If (Num1(k) = "0") Then
i = i - 1
Else
Cha1(j) = M2(i - 1)
j = j + 1
i = i - 1
Zero = 0
End If
End If
Next k
Cha1(j - 1) = "元"
If (Cha2(0) = "") Then
Cha1(j) = "整"
End If
End If
''*****连接字符串*****
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
End If
End If
End If
End Function
'################################################################
'9.函数作用：计算某种税金
'################################################################
Public Function 税(fa)
Dim x
If (fa - 800) > 0 And (fa - 800) < 500 Then
x = (fa - 800) * 0.05
税 = x
ElseIf (fa - 800) >= 500 And (fa - 800) < 2000 Then
x = (fa - 800) * 0.1 - 25
税 = x
ElseIf (fa - 800) >= 2000 And (fa - 800) < 5000 Then
x = (fa - 800) * 0.15 - 125
税 = x
ElseIf (fa - 800) >= 5000 And (fa - 800) < 20000 Then
x = (fa - 800) * 0.2 - 375
税 = x
ElseIf (fa - 800) >= 20000 And (fa - 800) < 40000 Then
x = (fa - 800) * 0.25 - 1375
税 = x
ElseIf (fa - 800) >= 40000 And (fa - 800) < 60000 Then
x = (fa - 800) * 0.3 - 3375
税 = x
ElseIf (fa - 800) >= 60000 And (fa - 800) < 80000 Then
x = (fa - 800) * 0.35 - 6375
税 = x
ElseIf (fa - 800) >= 80000 And (fa - 800) < 100000 Then
x = (fa - 800) * 0.4 - 10375
税 = x
ElseIf (fa - 800) >= 100000 Then
x = (fa - 800) * 0.45 - 15375
税 = x
Else
End If
End Function
'################################################################
'10.函数作用：人民币大、小写转换
'################################################################
Function 小写(k)
Application.ScreenUpdating = False
m1 = Application.WorksheetFunction.Round(k * 100, 0)
n1 = Int(m1 / 100)
n2 = Int(m1 / 10) - n1 * 10
n3 = m1 - n1 * 100 - n2 * 10
e = Application.WorksheetFunction.Text(n1, "[DBNum1]")
f = Application.WorksheetFunction.Text(n2, "[DBNum1]")
g = Application.WorksheetFunction.Text(n3, "[DBNum1]")
If n3 = 0 Then
小写 = "人民币大写：" & e & "元" & "整"
End If
If (n3 <> 0) And (n2 <> 0) Then
小写 = "人民币大写：" & e & "元" & f & "角" & g & "分"
If n1 = 0 Then
小写 = "人民币大写：" & f & "角" & g & "分"
End If
End If
If (n3 = 0) And n2 <> 0 Then
小写 = "人民币大写：" & e & "元" & f & "角" & "整"
If n1 = 0 Then
小写 = "人民币大写：" & f & "角" & "整"
End If
End If
If (n3 <> 0) And (n2 = 0) Then
小写 = "人民币大写：" & e & "元" & g & "分"
If n1 = 0 Then
小写 = "人民币大写：" & g & "分"
End If
End If
If k = 0 Or k = "" Then
k = ""
End If
Application.ScreenUpdating = True
End Function
Function 大写(k)
Application.ScreenUpdating = False
m1 = Application.WorksheetFunction.Round(k * 100, 0)
n1 = Int(m1 / 100)
n2 = Int(m1 / 10) - n1 * 10
n3 = m1 - n1 * 100 - n2 * 10
e = Application.WorksheetFunction.Text(n1, "[dbnum2]")
f = Application.WorksheetFunction.Text(n2, "[dbnum2]")
g = Application.WorksheetFunction.Text(n3, "[dbnum2]")
If n3 = 0 Then
大写 = "人民币大写：" & e & "元" & "整"
End If
If (n3 <> 0) And (n2 <> 0) Then
大写 = "人民币大写：" & e & "元" & f & "角" & g & "分"
If n1 = 0 Then
大写 = "人民币大写：" & f & "角" & g & "分"
End If
End If
If (n3 = 0) And n2 <> 0 Then
大写 = "人民币大写：" & e & "元" & f & "角" & "整"
If n1 = 0 Then
大写 = "人民币大写：" & f & "角" & "整"
End If
End If
If (n3 <> 0) And (n2 = 0) Then
大写 = "人民币大写：" & e & "元" & f & g & "分"
If n1 = 0 Then
大写 = "人民币大写：" & g & "分"
End If
End If
If k = 0 Or k = "" Then
大写 = ""
End If
Application.ScreenUpdating = True
End Function
'################################################################
'11.函数作用：查汉字区位码
'################################################################
Public Function 区(fa$) As String
On Error Resume Next
Dim L1$, R1$, L$, R$, a, b$, c, d, e$
c = Len