从个人所得税专项扣除信息表中提取资料。

hyz00001

summer201401 发表于 2019-1-14 15:07
麻烦帮忙看一下，这个程序无法运行。
另外，关于采集表有几点实际困难需要解决
1. 从系统导出的采集表， ...

附件已经添加。主要代码如下：

1. Sub 个税提取()
   
2.     Dim br(65536, 20)
   
3.     Dim a, b, c, x, y, r, rx, ry, n, item
   
4.     For Each sht In Sheets
   
5.         sht.Activate
   
6.         If [a2] <> "个人所得税专项附加扣除信息表" Then GoTo nextsht
   
7.         rx = Cells(Rows.Count, 1).End(xlUp).Row
   
8.         ry = Cells(5, Columns.Count).End(xlToLeft).Column
   
9.         ar = Range(Cells(1, 1), Cells(rx, ry))
   
10.         item = item + 1
    
11.         br(item - 1, 0) = ar(4, 2) '姓名
    
12.         br(item - 1, 1) = "'" & ar(4, 6) '身份证
    
13.         br(item - 1, 2) = "'" & ar(5, 7) '手机号码
    
14.         '子女扣除
    
15.         n = Application.CountIf(Cells, "本人扣除比例")
    
16.         For c = 1 To n
    
17.             br(item - 1, 3) = br(item - 1, 3) + 1000 * ar(10 + c * 4, 7) / 100
    
18.             br(item - 1, 4) = br(item - 1, 4) & "," & ar(7 + c * 4, 3)
    
19.         Next c
    
20.             br(item - 1, 4) = Mid(br(item - 1, 4), 2, 99)  '"共" & c & "个小孩，他们是:" &
    
21.         '教育扣除
    
22.         c = Application.Match("当前继续教育起始时间", Application.Index(ar, , 2), 0)
    
23.         If ar(c, 3) <> "" Then br(item - 1, 5) = 400: br(item - 1, 6) = ar(c, 7) & ar(c, 3)
    
24.         '住房贷款
    
25.         c = Application.Match("房屋证书号码", Application.Index(ar, , 6), 0)
    
26.         If ar(c + 1, 7) = "是" Then br(item - 1, 7) = 500: br(item - 1, 8) = ar(c + 4, 7)
    
27.         If ar(c + 1, 7) = "否" Then br(item - 1, 7) = 1000: br(item - 1, 8) = ar(c + 4, 7)
    
28.         '租房
    
29.         c = Application.Match("租赁期止", Application.Index(ar, , 6), 0)
    
30.         If ar(c, 7) <> "" Then br(item - 1, 9) = 1500: br(item - 1, 10) = ar(c - 3, 3)
    
31.         '赡养老人
    
32.         c = Application.Match("本年度月扣除金额", Application.Index(ar, , 6), 0)
    
33.         If ar(c, 7) <> "" Then br(item - 1, 11) = ar(c, 7): br(item - 1, 12) = ar(c, 2)
    
34.         '大病扣除
    
35.         c = Application.Match("与纳税人关系", Application.Index(ar, , 6), 0)
    
36.         If ar(c - 1, 3) <> "" Then br(item - 1, 13) = ar(c, 5): br(item - 1, 14) = ar(c - 1, 3)
    
37.         '合计扣除
    
38.         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)
    
39. nextsht:
    
40.     Next sht
    
41.     Sheets("总表").Activate: Cells.ClearContents
    
42.     [a2].Resize(item, 16) = br: [a1].Resize(1, 16) = Split("姓名,身份证,手机,子女扣除,子女,教育扣除,教育,贷款扣除,贷款银行,租房扣除,出租房,赡养扣除,是否独生子女,大病扣除,大病人,合计扣除", ",")
    
43. ' Stop
    
44. End Sub
    
45. Sub CombineWorkbooks()
    
46.     '合并工作薄
    
47.     Dim FilesToOpen
    
48.     Dim x As Integer
    
49. '   On Error GoTo ErrHandler
    
50.     Application.ScreenUpdating = False
    
51.     Workbooks.Add
    
52.     u = ActiveWorkbook.Name
    
53.     FilesToOpen = Application.GetOpenFilename(FileFilter:="MicroSoft Excel文件(*.*),*.*", MultiSelect:=True, Title:="要合并的文件")
    
54.     If TypeName(FilesToOpen) = "Boolean" Then
    
55.         MsgBox "没有选中文件"
    
56.         GoTo ExitHandler
    
57.     End If
    
58.     x = 1
    
59.     While x <= UBound(FilesToOpen)
    
60.         Workbooks.Open Filename:=FilesToOpen(x)
    
61.         
    
62.         w = ActiveWorkbook.Name
    
63.         w = Replace(w, ".XLSX", "")
    
64.         w = Replace(w, ".XLS", "")
    
65.         w = Replace(w, "结果", "")
    
66.         If Sheets.Count = 1 Then ActiveSheet.Name = Left(Replace(Replace(Split(ActiveWorkbook.Name, ".x")(0), " ", ""), Chr(13), ""), 31)
    
67.         For i = 1 To Sheets.Count
    
68.             Workbooks(w).Sheets(1).Move before:=Workbooks(u).Sheets(1)
    
69.             NewName = Replace(w, ".xls", "") & ActiveSheet.Name
    
70.             NewName = Replace(w, ".xlsx", "") & ActiveSheet.Name
    
71.             If SheetExist(NewName) Then NewName = NewName & i
    
72. '            ActiveSheet.Name = NewName
    
73.         Next
    
74.         x = x + 1
    
75.     Wend
    
76.    
    
77. ExitHandler:
    
78.     Application.ScreenUpdating = True
    
79.     Exit Sub
    
80. ErrHandler:
    
81.     MsgBox Err.Description
    
82.     Resume ExitHandler
    
83. End Sub
    

复制代码

hyz00001

个税抵扣提取信息模板.rar (36.82 KB, 下载次数: 79)

2019-1-14 16:03 上传

点击文件名下载附件

附件已经上传，请大家先用着。主要界面如下：

qq156059757

楼主发的附件清除之后 在 点击提取信息   显示
数据类型不符   c = Application.Match("当前继续教育起始时间", Application.Index(ar, , 2), 0)

qq156059757

楼主的附件清除之后 再提取
显示  
        c = Application.Match("当前继续教育起始时间", Application.Index(ar, , 2), 0)
运行时错误13
类型不匹配

hyz00001

summer201401 发表于 2019-1-14 15:07
麻烦帮忙看一下，这个程序无法运行。
另外，关于采集表有几点实际困难需要解决
1. 从系统导出的采集表， ...

合并工作簿的代码已经放在上面模板的代码表中。现在再粘贴一次。
合并工作簿也可以自己找易用宝或者是找andysky的专业软件来实现。

下面的代码是很久之前编写的。凑合着用吧。

1. Sub CombineWorkbooks()
   
2.     '合并工作薄
   
3.     Dim FilesToOpen
   
4.     Dim x As Integer
   
5. '   On Error GoTo ErrHandler
   
6.     Application.ScreenUpdating = False
   
7.     Workbooks.Add
   
8.     u = ActiveWorkbook.Name
   
9.     FilesToOpen = Application.GetOpenFilename(FileFilter:="MicroSoft Excel文件(*.*),*.*", MultiSelect:=True, title:="要合并的文件")
   
10.     If TypeName(FilesToOpen) = "Boolean" Then
    
11.         MsgBox "没有选中文件"
    
12.         GoTo ExitHandler
    
13.     End If
    
14.     x = 1
    
15.     While x <= UBound(FilesToOpen)
    
16.         Workbooks.Open Filename:=FilesToOpen(x)
    
17.         
    
18.         w = ActiveWorkbook.Name
    
19.         w = Replace(w, ".XLSX", "")
    
20.         w = Replace(w, ".XLS", "")
    
21.         w = Replace(w, "结果", "")
    
22.         If Sheets.Count = 1 Then ActiveSheet.Name = Left(Replace(Replace(Split(ActiveWorkbook.Name, ".x")(0), " ", ""), Chr(13), ""), 31)
    
23.         For i = 1 To Sheets.Count
    
24.             Workbooks(w).Sheets(1).Move before:=Workbooks(u).Sheets(1)
    
25.             NewName = Replace(w, ".xls", "") & ActiveSheet.Name
    
26.             NewName = Replace(w, ".xlsx", "") & ActiveSheet.Name
    
27.             If SheetExist(NewName) Then NewName = NewName & i
    
28. '            ActiveSheet.Name = NewName
    
29.         Next
    
30.         x = x + 1
    
31.     Wend
    
32.    
    
33. ExitHandler:
    
34.     Application.ScreenUpdating = True
    
35.     Exit Sub
    
36. ErrHandler:
    
37.     MsgBox Err.Description
    
38.     Resume ExitHandler
    
39. End Sub

复制代码

hyz00001

合并工作簿的代码已经放在上面模板的代码表中。现在再粘贴一次。
合并工作簿也可以自己找易用宝或者是找andysky的专业软件来实现。

下面的代码是很久之前编写的。凑合着用吧。

1. Sub CombineWorkbooks()
   
2.     '合并工作薄
   
3.     Dim FilesToOpen
   
4.     Dim x As Integer
   
5. '   On Error GoTo ErrHandler
   
6.     Application.ScreenUpdating = False
   
7.     Workbooks.Add
   
8.     u = ActiveWorkbook.Name
   
9.     FilesToOpen = Application.GetOpenFilename(FileFilter:="MicroSoft Excel文件(*.*),*.*", MultiSelect:=True, title:="要合并的文件")
   
10.     If TypeName(FilesToOpen) = "Boolean" Then
    
11.         MsgBox "没有选中文件"
    
12.         GoTo ExitHandler
    
13.     End If
    
14.     x = 1
    
15.     While x <= UBound(FilesToOpen)
    
16.         Workbooks.Open Filename:=FilesToOpen(x)
    
17.         
    
18.         w = ActiveWorkbook.Name
    
19.         w = Replace(w, ".XLSX", "")
    
20.         w = Replace(w, ".XLS", "")
    
21.         w = Replace(w, "结果", "")
    
22.         If Sheets.Count = 1 Then ActiveSheet.Name = Left(Replace(Replace(Split(ActiveWorkbook.Name, ".x")(0), " ", ""), Chr(13), ""), 31)
    
23.         For i = 1 To Sheets.Count
    
24.             Workbooks(w).Sheets(1).Move before:=Workbooks(u).Sheets(1)
    
25.             NewName = Replace(w, ".xls", "") & ActiveSheet.Name
    
26.             NewName = Replace(w, ".xlsx", "") & ActiveSheet.Name
    
27.             If SheetExist(NewName) Then NewName = NewName & i
    
28. '            ActiveSheet.Name = NewName
    
29.         Next
    
30.         x = x + 1
    
31.     Wend
    
32.    
    
33. ExitHandler:
    
34.     Application.ScreenUpdating = True
    
35.     Exit Sub
    
36. ErrHandler:
    
37.     MsgBox Err.Description
    
38.     Resume ExitHandler
    
39. End Sub

复制代码

simic1989

hyz00001 发表于 2019-1-14 16:04
附件已经上传，请大家先用着。主要界面如下：

您好，从您这个附件下载下来，运行提示
excel版本是2016,32位。

qq156059757

simic1989 发表于 2019-1-14 16:28
您好，从您这个附件下载下来，运行提示
excel版本是2016,32位。

office 2016同样的问题

qq156059757

spark999 发表于 2019-1-12 00:11
首光非常感谢楼主的分享！及时地解决我目前的问题。

执行中  发现类似     c = Application.Match("当前 ...

这位大神 你的附件什么时候发啊
兄弟们等着膜拜呢

hyz00001

qq156059757 发表于 2019-1-14 16:13
楼主发的附件清除之后 在 点击提取信息   显示
数据类型不符   c = Application.Match("当前继续教育起始 ...

如果是只有这一个问题就好办了。
c = Application.Match("当前继续教育起始时间", Application.Index(ar, , 2), 0)
上面这句话的意思是：在整个表里面的第二列去找“当前继续教育起始时间”字符，如果没有找到，应该就会是错误。
你可以把这句话换成查找其他的内容的。或者是直接跳过这句话。这个只是用来去匹配教育扣除。