附件已经添加。主要代码如下:
- Sub 个税提取()
- Dim br(65536, 20)
- Dim a, b, c, x, y, r, rx, ry, n, item
- For Each sht In Sheets
- sht.Activate
- If [a2] <> "个人所得税专项附加扣除信息表" Then GoTo nextsht
- rx = Cells(Rows.Count, 1).End(xlUp).Row
- ry = Cells(5, Columns.Count).End(xlToLeft).Column
- ar = Range(Cells(1, 1), Cells(rx, ry))
- item = item + 1
- br(item - 1, 0) = ar(4, 2) '姓名
- br(item - 1, 1) = "'" & ar(4, 6) '身份证
- br(item - 1, 2) = "'" & ar(5, 7) '手机号码
- '子女扣除
- n = Application.CountIf(Cells, "本人扣除比例")
- For c = 1 To n
- br(item - 1, 3) = br(item - 1, 3) + 1000 * ar(10 + c * 4, 7) / 100
- br(item - 1, 4) = br(item - 1, 4) & "," & ar(7 + c * 4, 3)
- Next c
- br(item - 1, 4) = Mid(br(item - 1, 4), 2, 99) '"共" & c & "个小孩,他们是:" &
- '教育扣除
- c = Application.Match("当前继续教育起始时间", Application.Index(ar, , 2), 0)
- If ar(c, 3) <> "" Then br(item - 1, 5) = 400: br(item - 1, 6) = ar(c, 7) & ar(c, 3)
- '住房贷款
- c = Application.Match("房屋证书号码", Application.Index(ar, , 6), 0)
- If ar(c + 1, 7) = "是" Then br(item - 1, 7) = 500: br(item - 1, 8) = ar(c + 4, 7)
- If ar(c + 1, 7) = "否" Then br(item - 1, 7) = 1000: br(item - 1, 8) = ar(c + 4, 7)
- '租房
- c = Application.Match("租赁期止", Application.Index(ar, , 6), 0)
- If ar(c, 7) <> "" Then br(item - 1, 9) = 1500: br(item - 1, 10) = ar(c - 3, 3)
- '赡养老人
- c = Application.Match("本年度月扣除金额", Application.Index(ar, , 6), 0)
- If ar(c, 7) <> "" Then br(item - 1, 11) = ar(c, 7): br(item - 1, 12) = ar(c, 2)
- '大病扣除
- c = Application.Match("与纳税人关系", Application.Index(ar, , 6), 0)
- If ar(c - 1, 3) <> "" Then br(item - 1, 13) = ar(c, 5): br(item - 1, 14) = ar(c - 1, 3)
- '合计扣除
- br(item - 1, 15) = br(item - 1, 3) + br(item - 1, 5) + br(item - 1, 7) + br(item - 1, 9) + br(item - 1, 11) + br(item - 1, 13)
- nextsht:
- Next sht
- Sheets("总表").Activate: Cells.ClearContents
- [a2].Resize(item, 16) = br: [a1].Resize(1, 16) = Split("姓名,身份证,手机,子女扣除,子女,教育扣除,教育,贷款扣除,贷款银行,租房扣除,出租房,赡养扣除,是否独生子女,大病扣除,大病人,合计扣除", ",")
- ' Stop
- End Sub
- Sub CombineWorkbooks()
- '合并工作薄
- Dim FilesToOpen
- Dim x As Integer
- ' On Error GoTo ErrHandler
- Application.ScreenUpdating = False
- Workbooks.Add
- u = ActiveWorkbook.Name
- FilesToOpen = Application.GetOpenFilename(FileFilter:="MicroSoft Excel文件(*.*),*.*", MultiSelect:=True, Title:="要合并的文件")
- If TypeName(FilesToOpen) = "Boolean" Then
- MsgBox "没有选中文件"
- GoTo ExitHandler
- End If
- x = 1
- While x <= UBound(FilesToOpen)
- Workbooks.Open Filename:=FilesToOpen(x)
-
- w = ActiveWorkbook.Name
- w = Replace(w, ".XLSX", "")
- w = Replace(w, ".XLS", "")
- w = Replace(w, "结果", "")
- If Sheets.Count = 1 Then ActiveSheet.Name = Left(Replace(Replace(Split(ActiveWorkbook.Name, ".x")(0), " ", ""), Chr(13), ""), 31)
- For i = 1 To Sheets.Count
- Workbooks(w).Sheets(1).Move before:=Workbooks(u).Sheets(1)
- NewName = Replace(w, ".xls", "") & ActiveSheet.Name
- NewName = Replace(w, ".xlsx", "") & ActiveSheet.Name
- If SheetExist(NewName) Then NewName = NewName & i
- ' ActiveSheet.Name = NewName
- Next
- x = x + 1
- Wend
-
- ExitHandler:
- Application.ScreenUpdating = True
- Exit Sub
- ErrHandler:
- MsgBox Err.Description
- Resume ExitHandler
- End Sub
复制代码
|