求一个代码，能否将文件夹内的个税申报表合并 再提取关键字列

Clove8

如题，能否将附件内的个税申报表合并成一个表 然后再提取姓名 收入列 根据税款所属期在姓名列前添加一列月份

万分感谢

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.2.5
   
2.     Dim arr, brr(1 To 10000, 1 To 50)
   
3.     Set Fso = CreateObject("scripting.filesystemobject")
   
4.     Set List = CreateObject("System.Collections.ArrayList")
   
5.     Application.ScreenUpdating = False
   
6.     Set sh = ThisWorkbook.Sheets("个人所得税扣缴申报表")
   
7.     p = ThisWorkbook.Path & ""
   
8.     For Each f In Fso.GetFolder(p).Files
   
9.         If f.Name Like "*.xls*" Then
   
10.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
11.                 fn = Fso.GetBaseName(f)
    
12.                 ny = Split(fn, "_")(0)
    
13.                 List.Add ny
    
14.                 Set wb = Workbooks.Open(f, 0)
    
15.                 With wb.Sheets(1)
    
16.                     arr = .UsedRange
    
17.                     wb.Close False
    
18.                 End With
    
19.                 For i = 9 To UBound(arr)
    
20.                     If Val(arr(i, 1)) Then
    
21.                         m = m + 1
    
22.                         brr(m, 1) = m
    
23.                         brr(m, 2) = Format(Val(Mid(fn, 6)), "00") & "月"
    
24.                         brr(m, 3) = arr(i, 2)
    
25.                         For j = 3 To UBound(arr, 2)
    
26.                             brr(m, j + 1) = arr(i, j)
    
27.                         Next
    
28.                     End If
    
29.                 Next
    
30.             End If
    
31.         End If
    
32.     Next f
    
33.     List.Sort
    
34.     rq1 = Format(CDate(List(0)), "yyyy年mm月dd日")
    
35.     rq2 = Replace(Format(CDate(List(List.Count - 1)), "yyyy年mm月dd日"), "01日", "31日")
    
36.     st = "税款所属期： " & rq1 & "至" & rq2
    
37.     With sh
    
38.         .[a2] = st
    
39.         .UsedRange.Offset(8).Clear
    
40.         .Columns(2).NumberFormatLocal = "@"
    
41.         With .[a9].Resize(m, 43)
    
42.             .Value = brr
    
43.             .Borders.LineStyle = 1
    
44.             .HorizontalAlignment = xlCenter
    
45.             .VerticalAlignment = xlCenter
    
46.         End With
    
47.         ActiveWindow.DisplayZeros = False
    
48.     End With
    
49.     Application.ScreenUpdating = True
    
50.     MsgBox "OK！"
    
51. End Sub
    

复制代码

opiona

https://club.excelhome.net/thread-1409141-1-1.html

ykcbf1100

汇总表第二行数据代码会根据文件月份自动提取。
附件供参考。。。

Clove8

ykcbf1100 发表于 2024-2-5 20:53
汇总表第二行数据代码会根据文件月份自动提取。
附件供参考。。。

感谢 然后我想问下 我还有其他类型的表 我把代码里的改一下就可以了么 还有运行的时候下标越界的情况怎么解决

ykcbf1100

Clove8 发表于 2024-2-18 14:16
感谢 然后我想问下 我还有其他类型的表 我把代码里的改一下就可以了么 还有运行的时候下标越界的情况怎么 ...

还是要根据实际情况来处理。原代码只对附件有效。

A刘志勇

ykcbf1100 发表于 2024-2-18 16:12
还是要根据实际情况来处理。原代码只对附件有效。