VBA自定义函数集锦

1、返回 Column 英文字：

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、作用说明：
相当于VLOOKUP吧，查询某一值第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

3、

求个人所得税Grsds(bsc,mysala)

该函数返回一个个人工资薪金所得应纳个人所得税税额。

语法：Grsds(bsc,mysala)
其中：
bsc,必选项，为起征点，包括税法规定的工资基数800元加上允许税前扣除的合理费用；
mysala,必选项，为人个工资薪金所得。

示例：
Grsds(850,20000)=3455.00
返回当个人工资薪金所得为2000元(起征点为850元)时的应纳个人所得税税额。

求个人所得税Grsds(bsc,mysala)

该函数返回一个个人工资薪金所得应纳个人所得税税额。

语法：Grsds(bsc,mysala)
其中：
bsc,必选项，为起征点，包括税法规定的工资基数800元加上允许税前扣除的合理费用；
mysala,必选项，为人个工资薪金所得。

示例：
Grsds(850,20000)=3455.00
返回当个人工资薪金所得为2000元(起征点为850元)时的应纳个人所得税税额。

Function Grsds() Function Grsds(bsc As Double, mysala As Double) As Double
'bsc为起征点加上允许税前扣除的合理费用,mysala为工资薪金所得
'author：tanjh
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

4、金额数字转中文大写，财务人员必备

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

转载于:https://www.cnblogs.com/wangminbai/archive/2008/02/23/1078460.html