|
|
本帖最后由 woshiyanhao 于 2019-4-28 10:58 编辑
个税计算2019.rar
(37.82 KB, 下载次数: 267)
本人作为财务工作者初学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
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2019-4-28 10:55
