access vba 自定义函数 vba常用自定义函数

转载

mob64ca1411e411 2024-03-05 23:40:32

文章标签 access 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

本文章为转载内容，我们尊重原作者对文章享有的著作权。如有内容错误或侵权问题，欢迎原作者联系我们进行内容更正或删除文章。