个税计算2019（用VBA做的，作为初学者一枚请大家测试）

woshiyanhao

个税计算2019.rar (37.82 KB, 下载次数: 267)

2019-4-28 10:39 上传

点击文件名下载附件

本人作为财务工作者初学VBA，用到了一些非常基础的东西：fornext循环汇总并计数、arr()数组、Inputbox取数、find查找、add工作表新增、range单元格复制粘贴、IF计算个税。中间有一些数组的操作比较笨，有兴趣的朋友可以直接帮我改改，感谢。QQ:44588515

Sub 个税计算2019() '联系作者：QQ:44588515或44588515@qq.com
Dim m '需要计算工资的月份
Dim st As Worksheet '工作表
Dim i% '1-m月份
Dim xm As Range '查找“姓名”所在的单元格
Dim hj As Range '查找“合计”所在的单元格
Dim sm As Range '查找“说明”所在的单元格
Dim sb As Range '查找“单位社保”所在的单元格，求和第一列
Dim fr% '数据的首行
Dim fc% '数据的首列
Dim lr% '数据的末行
Dim lc% '数据的末列
Dim rs% '单表数据行数
Dim rss% '合并数据行数
Dim arr() '第一个数组一维
Dim j% '过渡变量无意义
Dim n% '合并后数据的序列
Dim sfr%, sfc%, slr%, slc% '将需当前月份的数据区域尺寸换一个变量进行保留
Dim brr() '第二个数组将汇总的数据转置成二维数组
Dim name '当月工资表中的人名（过渡变量无意义）
Dim x% '汇总数据数组的行变量（过渡变量无意义）
Dim y% '汇总数据数组的列变量（过渡变量无意义）
Dim qh% '工资表中需要求和的第1列，即数值列
Dim crr() '第三个数组汇总后的新数组
Dim flag As Boolean '判别真假
Dim sgz '社保+公积金+专项附加.之前设的long出来没有小数部分，不知道为何。
Dim sq '税前
Dim wt As Worksheet 'vba汇总表
Dim dq As Worksheet '当前月份工资表
Dim yj '应交税金
Dim g% '出现的人次计数
Dim drr() '第4个数组计数的小数组

m = InputBox("想算几月的个税？", , Month(Date) - 1)
If m = "" Then Exit Sub

For Each st In Sheets
    For i = 1 To m
        If st.name = "2019." & i Then
            Set xm = st.Range("E5").CurrentRegion.Find("姓名", LookIn:=xlValues, lookat:=xlWhole)
            Set hj = st.Range("E5").CurrentRegion.Find("合计", LookIn:=xlValues, lookat:=xlWhole)
            Set sm = st.Range("E5").CurrentRegion.Find("说明", LookIn:=xlValues, lookat:=xlWhole)
            Set sb = st.Range("E5").CurrentRegion.Find("单位" & Chr(10) & "社保", LookIn:=xlValues, lookat:=xlWhole)
                If Not xm Is Nothing Then
                    fr = xm.Row + 2
                    fc = xm.Column
                End If
                If Not hj Is Nothing Then
                    lr = hj.Row - 1
                End If
                If Not sm Is Nothing Then
                    lc = sm.Column
                End If
                If Not sb Is Nothing Then
                    qh = sb.Column
                End If

                If i = m Then
                    sfr = fr
                    sfc = fc
                    slr = lr
                    slc = lc
                End If

                rs = lr - fr + 1
                rss = rss + rs
                ReDim Preserve arr(1 To rss)

                For j = fr To lr
                    n = n + 1
                    arr(n) = st.Range(st.Cells(j, fc), st.Cells(j, lc))
                Next j
        End If
    Next i
Next st

brr() = Application.Transpose(Application.Transpose(arr))
ReDim crr(1 To slr - sfr + 1, 1 To UBound(brr, 2))

Worksheets("2019." & m).Select
With Worksheets("2019." & m)
    ReDim drr(1 To slr - sfr + 1)
    For name = sfr To slr
        g = 0
            For x = 1 To n
                If .Cells(name, sfc) = brr(x, 1) Then
                    g = g + 1
                    For y = qh - 1 To UBound(brr, 2) - 1
                        crr(name - sfr + 1, y) = brr(x, y) + crr(name - sfr + 1, y)
                    Next y
                End If
            Next x
        drr(name - sfr + 1) = g
    Next name
End With

flag = False
For i = 1 To ThisWorkbook.Worksheets.Count
    Set wt = ThisWorkbook.Worksheets(i)
    If wt.name = "vba汇总" Then
        flag = True
        Exit For
    End If
Next i

If flag = True Then
   Worksheets("vba汇总").UsedRange.ClearContents
Else
   Sheets.Add After:=ActiveSheet
   ActiveSheet.name = "vba汇总"
End If
Set wt = Nothing

Set wt = ThisWorkbook.Worksheets("vba汇总")
Set dq = ThisWorkbook.Worksheets("2019." & m)
    With wt
        .Select
        .Cells(sfr, sfc).Resize(UBound(crr, 1), UBound(brr, 2)) = crr()
        dq.Range("1:3").Copy .Range("a1")
        dq.Range("A:C").Copy .Range("a1")


Set sm = wt.Range("E5").CurrentRegion.Find("说明", LookIn:=xlValues, lookat:=xlWhole)

sm.Offset(1, 0).Resize(UBound(drr)) = Application.Transpose(drr())

For i = sfr To slr
    sgz = Round(Application.WorksheetFunction.Sum(Range(Cells(i, "O"), Cells(i, "U"))), 2)
    sq = Cells(i, "N") - sgz - Cells(i, "X") * 5000
    sm.Offset(0, 1) = "累计应交"
    sm.Offset(0, 2) = "本月应交"
    If sq < 0 Then
        yj = 0
        ElseIf sq < 36000 Then
        yj = sq * 3 / 100
        ElseIf sq < 144000 Then
        yj = sq * 10 / 100 - 2520
        ElseIf sq < 300000 Then
        yj = sq * 20 / 100 - 16920
        ElseIf sq < 420000 Then
        yj = sq * 25 / 100 - 31920
        ElseIf sq < 660000 Then
        yj = sq * 30 / 100 - 52920
        ElseIf sq < 960000 Then
        yj = sq * 35 / 100 - 85920
        Else
        yj = sq * 45 / 100 - 181920
    End If
    .Cells(i, slc + 1) = yj

    If .Cells(i, slc + 1) - .Cells(i, slc - 2) > 0 Then
        .Cells(i, slc + 2) = Round(.Cells(i, slc + 1) - .Cells(i, slc - 2), 2)
        Else
        .Cells(i, slc + 2) = 0
    End If


Next i

    End With
End Sub

zhgfeng1988

本月应交税额不显示啊！！

zwdong

新增加月出错。不知道什么原因。

luanyu6688

提示出错，with未定义