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

blackttea1

能发个2003版的不？谢谢

qq156059757

楼主，麻烦给看看，如何将附件中的三个表格汇总到汇总表里
现在可以有几千个表格需要汇总，我只上传了3个
我看到有很多朋友遇到这样的问题 ，但是都么有解决
麻烦您看一下

fdexcel

其实不需要把所有的复制到表。根据你的代码改了下，把放进同一个文件夹就可以了，不过试了下，office2016运行的会提示类型不匹配。wps运行正常

1. 
   
2. 
   
3. Sub 合并()
   
4.     Dim MyPath As String, MyFile As String, i As Integer
   
5.     Dim Wb As Workbook, arr
   
6.     Application.ScreenUpdating = False
   
7.     MyPath = ThisWorkbook.Path
   
8.     MyFile = Dir(MyPath & "\*.xls*")
   
9.     Do Until MyFile = ""
   
10.         If MyFile <> ThisWorkbook.Name Then
    
11.             Set Wb = Workbooks.Open(MyPath & "" & MyFile)
    
12. 
    
13.     Dim br(65536, 20)
    
14.     Dim a, b, c, x, y, r, rx, ry, n, item
    
15.    
    
16.    
    
17.    
    
18.     For Each sht In Sheets
    
19.         sht.Activate
    
20.         If [a2] <> "个人所得税专项附加扣除信息表" Then GoTo nextsht
    
21.         rx = Cells(Rows.Count, 1).End(xlUp).Row
    
22.         ry = Cells(5, Columns.Count).End(xlToLeft).Column
    
23.         ar = Range(Cells(1, 1), Cells(rx, ry))
    
24.         item = item + 1
    
25.         br(item - 1, 0) = ar(4, 2) '姓名
    
26.         br(item - 1, 1) = "'" & ar(4, 6) '身份证
    
27.         br(item - 1, 2) = "'" & ar(5, 7) '手机号码
    
28.         '子女扣除
    
29.         n = Application.CountIf(Cells, "本人扣除比例")
    
30.         For c = 1 To n
    
31.             br(item - 1, 3) = br(item - 1, 3) + 1000 * ar(10 + c * 4, 7) / 100
    
32.             br(item - 1, 4) = br(item - 1, 4) & "," & ar(7 + c * 4, 3)
    
33.         Next c
    
34.             br(item - 1, 4) = Mid(br(item - 1, 4), 2, 99)  '"共" & c & "个小孩，他们是:" &
    
35.         '教育扣除
    
36.         c = Application.Match("当前继续教育起始时间", Application.Index(ar, , 2), 0)
    
37.         If ar(c, 3) <> "" Then br(item - 1, 5) = 400: br(item - 1, 6) = ar(c, 7) & ar(c, 3)
    
38.         '住房贷款
    
39.         c = Application.Match("房屋证书号码", Application.Index(ar, , 6), 0)
    
40.         If ar(c + 1, 7) = "是" Then br(item - 1, 7) = 500: br(item - 1, 8) = ar(c + 4, 7)
    
41.         If ar(c + 1, 7) = "否" Then br(item - 1, 7) = 1000: br(item - 1, 8) = ar(c + 4, 7)
    
42.         '租房
    
43.         c = Application.Match("租赁期止", Application.Index(ar, , 6), 0)
    
44.         If ar(c, 7) <> "" Then br(item - 1, 9) = 1500: br(item - 1, 10) = ar(c - 3, 3)
    
45.         '赡养老人
    
46.         c = Application.Match("本年度月扣除金额", Application.Index(ar, , 6), 0)
    
47.         If ar(c, 7) <> "" Then br(item - 1, 11) = ar(c, 7): br(item - 1, 12) = ar(c, 2)
    
48.         '大病扣除
    
49.         c = Application.Match("与纳税人关系", Application.Index(ar, , 6), 0)
    
50.         If ar(c - 1, 3) <> "" Then br(item - 1, 13) = ar(c, 5): br(item - 1, 14) = ar(c - 1, 3)
    
51.         '合计扣除
    
52.         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)
    
53. nextsht:
    
54.      Next sht
    
55.    
    
56.                  Wb.Close
    
57.             
    
58.                 [a2].Resize(item, 16) = br
    
59.         End If
    
60.         MyFile = Dir
    
61.     Loop
    
62.     Application.ScreenUpdating = True
    
63.    
    
64. End Sub
    

复制代码

summer201401

hyz00001 发表于 2019-1-14 16:02
附件已经添加。主要代码如下：

运行附件的程序，提示错误“13”，类型不匹配呀

hyz00001

按照要求增加一个2003的模板。
还有增加了合并表与添加目录两个按钮。


模板下载地址如下： 个税抵扣提取信息模板XLS.rar (128.29 KB, 下载次数: 320)

2019-1-15 11:21 上传

点击文件名下载附件

模块中的代码就是这个。验证了应该是可以运算出来结果，并且有截图在上面。

1. Function SheetExist(ByVal Sheetname As String) As Boolean '判断工作表是否存在
   
2. Application.Volatile '易失标记
   
3. Dim s As String, b As Boolean
   
4. b = False
   
5. On Error GoTo bottom
   
6.     s = Sheets(Sheetname).Name
   
7.     b = True
   
8. bottom: SheetExist = b
   
9. End Function
   
10. 
    
11. Sub 个税提取()
    
12.     Dim br(65536, 20)
    
13.     Dim a, b, c, x, y, r, rx, ry, n, item
    
14.     For Each sht In Sheets
    
15.         sht.Activate
    
16.         If [a2] <> "个人所得税专项附加扣除信息表" Then GoTo nextsht
    
17.         rx = Cells(Rows.Count, 1).End(xlUp).Row
    
18.         ry = Cells(5, Columns.Count).End(xlToLeft).Column
    
19.         ar = Range(Cells(1, 1), Cells(rx, ry))
    
20.         item = item + 1
    
21.         br(item - 1, 0) = ar(4, 2) '姓名
    
22.         br(item - 1, 1) = "'" & ar(4, 6) '身份证
    
23.         br(item - 1, 2) = "'" & ar(5, 7) '手机号码
    
24.         '子女扣除
    
25.         n = Application.CountIf(Cells, "本人扣除比例")
    
26.         For c = 1 To n
    
27.             br(item - 1, 3) = br(item - 1, 3) + 1000 * ar(10 + c * 4, 7) / 100
    
28.             br(item - 1, 4) = br(item - 1, 4) & "," & ar(7 + c * 4, 3)
    
29.         Next c
    
30.             br(item - 1, 4) = Mid(br(item - 1, 4), 2, 99)  '"共" & c & "个小孩，他们是:" &
    
31.         '教育扣除
    
32.         c = Application.Match("当前继续教育起始时间", Application.Index(ar, , 2), 0)
    
33.         If ar(c, 3) <> "" Then br(item - 1, 5) = 400: br(item - 1, 6) = ar(c, 7) & ar(c, 3)
    
34.         '住房贷款
    
35.         c = Application.Match("房屋证书号码", Application.Index(ar, , 6), 0)
    
36.         If ar(c + 1, 7) = "是" Then br(item - 1, 7) = 500: br(item - 1, 8) = ar(c + 4, 7)
    
37.         If ar(c + 1, 7) = "否" Then br(item - 1, 7) = 1000: br(item - 1, 8) = ar(c + 4, 7)
    
38.         '租房
    
39.         c = Application.Match("租赁期止", Application.Index(ar, , 6), 0)
    
40.         If ar(c, 7) <> "" Then br(item - 1, 9) = 1500: br(item - 1, 10) = ar(c - 3, 3)
    
41.         '赡养老人
    
42.         c = Application.Match("本年度月扣除金额", Application.Index(ar, , 6), 0)
    
43.         If ar(c, 7) <> "" Then br(item - 1, 11) = ar(c, 7): br(item - 1, 12) = ar(c, 2)
    
44.         '大病扣除
    
45.         c = Application.Match("与纳税人关系", Application.Index(ar, , 6), 0)
    
46.         If ar(c - 1, 3) <> "" Then br(item - 1, 13) = ar(c, 5): br(item - 1, 14) = ar(c - 1, 3)
    
47.         '合计扣除
    
48.         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)
    
49. nextsht:
    
50.     Next sht
    
51.     Sheets("总表").Activate: Cells.ClearContents
    
52.     [a2].Resize(item, 16) = br: [a1].Resize(1, 16) = Split("姓名,身份证,手机,子女扣除,子女,教育扣除,教育,贷款扣除,贷款银行,租房扣除,出租房,赡养扣除,是否独生子女,大病扣除,大病人,合计扣除", ",")
    
53. ' Stop
    
54. End Sub
    
55. Sub CombineWorkbooks()
    
56.     '合并工作薄
    
57.     Dim FilesToOpen
    
58.     Dim x As Integer
    
59. '   On Error GoTo ErrHandler
    
60.     Application.ScreenUpdating = False
    
61.     'Workbooks.Add
    
62.     u = ActiveWorkbook.Name
    
63.     FilesToOpen = Application.GetOpenFilename(FileFilter:="MicroSoft Excel文件(*.*),*.*", MultiSelect:=True, Title:="要合并的文件")
    
64.     If TypeName(FilesToOpen) = "Boolean" Then
    
65.         MsgBox "没有选中文件"
    
66.         GoTo ExitHandler
    
67.     End If
    
68.     x = 1
    
69.     While x <= UBound(FilesToOpen)
    
70.         Workbooks.Open Filename:=FilesToOpen(x)
    
71.         
    
72.         w = ActiveWorkbook.Name
    
73.         w = Replace(w, ".XLSX", "")
    
74.         w = Replace(w, ".XLS", "")
    
75.         w = Replace(w, "结果", "")
    
76.         If Sheets.Count = 1 Then ActiveSheet.Name = Left(Replace(Replace(Split(ActiveWorkbook.Name, ".x")(0), " ", ""), Chr(13), ""), 31)
    
77.         For i = 1 To Sheets.Count
    
78.             Workbooks(w).Sheets(1).Move after:=Workbooks(u).Sheets(Sheets.Count)
    
79.             NewName = Replace(w, ".xls", "") & ActiveSheet.Name
    
80.             NewName = Replace(w, ".xlsx", "") & ActiveSheet.Name
    
81.             If SheetExist(NewName) Then NewName = NewName & i
    
82. '            ActiveSheet.Name = NewName
    
83.         Next
    
84.         x = x + 1
    
85.     Wend
    
86.    
    
87. ExitHandler:
    
88.     Application.ScreenUpdating = True
    
89.     Exit Sub
    
90. ErrHandler:
    
91.     MsgBox Err.Description
    
92.     Resume ExitHandler
    
93. End Sub
    
94. Sub mulu()
    
95. 'Application.Calculation = xlManual
    
96.     Application.ScreenUpdating = False              '取消刷新屏幕以便加快运行代码
    
97.     Application.DisplayAlerts = False
    
98.     '创建工作表目录
    
99.     On Error GoTo r                   '如遇到错误语句将直接挑到R运行
    
100.     Dim i As Integer                    '定义I,shtcount和SelectionCell变量
     
101.     Dim ShtCount As Integer
     
102.     Dim SelectionCell As Range
     
103.     ShtCount = Worksheets.Count
     
104.     If ShtCount = 0 Or ShtCount = 1 Then Exit Sub     '工作簿内仅0或1张工作表时候退出
     
105. '    For I = 1 To ShtCount                         '遍历所有工作表
     
106.     If SheetExist("目录") Then
     
107.         For x = 1 To 65
     
108.             If SheetExist("目录" & x) = 0 Then Sheets("目录").Name = "目录" & x: GoTo mulu2
     
109.             If SheetExist("目录" & x) = 0 Then Sheets("目录").Name = "目录" & x + 1: GoTo mulu2
     
110.         Next x
     
111.     End If
     
112. mulu2:
     
113.     Sheets.Add: ActiveSheet.Name = "目录"
     
114.     ActiveSheet.Move before:=Sheets(1)
     
115.     [a:c].Insert
     
116. '    If SheetExist("目录") Then
     
117. '        For x = 1 To 65
     
118. '            If SheetExist(Sheets("目录" & x)) Then
     
119. '                a = x
     
120. '            Else
     
121. '                Sheets("目录" & x).Name = "目录" & x + 1
     
122. '            End If
     
123. '        Next
     
124. '        Sheets("目录").Name
     
125. '    End If
     
126. '    If SheetExist("目录") Then SheetExist("目录").Delete
     
127. '        Sheets.Add
     
128. '    If Sheets(1).Name <> "目录" Then     '当第一张工作表名不为"目录"时候.生成"目录"
     
129. '        ShtCount = ShtCount + 1
     
130. '        Sheets.Add
     
131. '        ActiveSheet.Name = "目录"
     
132. '        ActiveSheet.Move before:=Sheets(1)
     
133. '    End If
     
134. '    Sheets("目录").Select              '选定工作表"目录"
     
135. '    Columns("B:B").Delete Shift:=xlToLeft   '清除B列
     
136. '    Application.StatusBar = "正在生成目录…………请等待！"   '添加等待状态条
     
137.     For i = 2 To Sheets.Count                '遍历除第一张工作表外所有工作表,建立链接
     
138.         ActiveSheet.Hyperlinks.Add Anchor:=Worksheets("目录").Cells(i, 2), Address:="", SubAddress:="'" & Sheets(i).Name & "'!R1C1", TextToDisplay:=Sheets(i).Name
     
139.         Worksheets("目录").Cells(i, 1) = i - 1
     
140.     Next
     
141.     Sheets("目录").Select
     
142.     Columns("B:B").AutoFit              '自动调整
     
143.     [b:b].NumberFormatLocal = "@"
     
144.    Cells(1, 1) = "号码"                                    'A列第一个单元格为 "号码"
     
145.     Cells(1, 2) = "目录"                                  'B列第一个单元格录"目录"
     
146.     Set SelectionCell = Worksheets("目录").Range("B1")
     
147.     With SelectionCell                                  '调整单元格格式
     
148.         .HorizontalAlignment = xlDistributed
     
149.         .VerticalAlignment = xlCenter
     
150.         .AddIndent = True
     
151.         .Font.Bold = True
     
152.         .Interior.ColorIndex = 34
     
153.     End With
     
154.     Application.StatusBar = False
     
155.     Application.ScreenUpdating = True
     
156.     Application.DisplayAlerts = True
     
157. r:
     
158. Application.Calculation = xlAutomatic
     
159. End Sub
     

复制代码

qq156059757

按楼主的意思   修改了一下
可以执行了
不过只能在一个工作表里汇总多个 sheet  不能汇总多个文件

hyz00001

qq156059757 发表于 2019-1-15 11:56
按楼主的意思   修改了一下
可以执行了
不过只能在一个工作表里汇总多个 sheet  不能汇总多个文件

你好，我刚才已经更新了一个xls文件的模板，那个里面添加了合并工作表，添加工作表目录两个比较好用的按钮，现在还在审核中，请耐心等待。

blackttea1

2003版出现类型不匹配，运行出错误出现在：
c = Application.Match("当前继续教育起始时间", Application.Index(ar, , 2), 0) 处

qq156059757

hyz00001 发表于 2019-1-15 12:00
你好，我刚才已经更新了一个xls文件的模板，那个里面添加了合并工作表，添加工作表目录两个比较好用的按 ...

楼主看一下，你发的附件中的命令，加粗的部分我改动了一下就不出现  错误13 类型不匹配了
添加了n=……   停止执行c=……
是什么原因呢


'子女扣除
        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 & "个小孩，他们是:" &
        '教育扣除
       n = Application.CountIf(Cells, "当前继续教育起始时间")
        '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)
        '住房贷款
         n = Application.CountIf(Cells, "房屋证书号码")
        '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)
        '租房
       n = Application.CountIf(Cells, "租赁期止")
        '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)
        '赡养老人
        n = Application.CountIf(Cells, "本年度月扣除金额")
        '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)
        '大病扣除
        n = Application.CountIf(Cells, "与纳税人关系")
        '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)

qq156059757

hyz00001 发表于 2019-1-15 12:00
你好，我刚才已经更新了一个xls文件的模板，那个里面添加了合并工作表，添加工作表目录两个比较好用的按 ...

2016版出现类型不匹配，运行出错误出现在：
c = Application.Match("当前继续教育起始时间", Application.Index(ar, , 2), 0) 处