提列数据和表名

ddz79101

taller 发表于 2024-2-21 14:02
更新代码

谢谢老师！我运行代码了，但出现下图片

ddz79101

ykcbf1100 发表于 2024-2-21 14:28
附件供参考。。。

谢谢老师！运行正确，表名看来还是需手工补上。

smiletwo

smiletwo

1. Sub ss() '事先填好汇总表的表头
   
2.     Dim i, j, k, m, arr, brr, sht As Worksheet, D1 As Object
   
3.     Set D1 = CreateObject("scripting.dictionary")
   
4.     arr = Sheet13.Range("A1").CurrentRegion
   
5.     For i = 3 To UBound(arr)
   
6.         D1(arr(i, 4)) = i
   
7.         '因姓名存在重复，建议用身份证号区分，arr(i,4)改为arr(i,2)
   
8.     Next i
   
9.     '汇总
   
10.     For j = 6 To UBound(arr, 2)
    
11.         If arr(2, j) Like "*险*" Then
    
12.             brr = Sheets(arr(2, j)).Range("A1").CurrentRegion
    
13.             For i = 3 To UBound(brr) - 1
    
14.                 If D1.exists(brr(i, 1)) Then
    
15.                     arr(D1(brr(i, 1)), j) = brr(i, 7)
    
16.                 End If
    
17.             Next i
    
18.         End If
    
19.     Next j
    
20.     '因附件中数值为文本格式，需要替换逗号，并转为数值
    
21.     For i = 3 To UBound(arr)
    
22.         For j = 6 To UBound(arr, 2)
    
23.             arr(i, j) = Val(Replace(arr(i, j), ",", ""))
    
24.         Next j
    
25.     Next i
    
26.     '小计、合计
    
27.     For i = 3 To UBound(arr)
    
28.         arr(i, 11) = arr(i, 6) + arr(i, 7) + arr(i, 8) + arr(i, 9) + arr(i, 10)
    
29.         arr(i, 15) = arr(i, 12) + arr(i, 13) + arr(i, 14)
    
30.         arr(i, 16) = arr(i, 11) + arr(i, 15)
    
31.     Next i
    
32.     Set D1 = Nothing
    
33.     Sheet13.UsedRange.ClearContents
    
34.     Sheet13.Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
    
35. End Sub

复制代码

ykcbf1100

ddz79101 发表于 2024-2-21 16:47
谢谢老师！运行正确，表名看来还是需手工补上。

也可以代码生成，但稍麻烦。

taller

ddz79101 发表于 2024-2-21 16:42
谢谢老师！我运行代码了，但出现下图片

中文乱码，请参考截图修改

ykcbf1100

ddz79101 发表于 2024-2-21 16:47
谢谢老师！运行正确，表名看来还是需手工补上。

改了一下，代码增加了通用性，标题行自动生成，小计列和合计列位置自动判定，表增加也不用改代码了。

ykcbf1100

代码如下，供参考。

1. Sub ykcbf()  '//2024.2.22
   
2.     Dim arr, brr, d, c(1 To 3)
   
3.     Set d = CreateObject("Scripting.Dictionary")
   
4.     Set d1 = CreateObject("Scripting.Dictionary")
   
5.     Set ws = ThisWorkbook
   
6.     Set sh = ws.Sheets("当月缴费人员")
   
7.     bt = [{"序号","公民身份证号","个人社会保险登记码","姓名","个人账户属性"}]
   
8.     b = [{"企业","个人"}]
   
9.     xj = [{"企业小计","个人小计","合计"}]
   
10.     For x = 1 To UBound(bt)
    
11.         d1(bt(x)) = ""
    
12.     Next
    
13.     For x = 1 To UBound(b)
    
14.         For Each sht In ws.Sheets
    
15.             If InStr(sht.Name, b(x)) Then
    
16.                 With sht
    
17.                     r = .UsedRange.Find("合计").Row - 1
    
18.                     arr = .Range("a1:g" & r)
    
19.                     fn = .Name
    
20.                 End With
    
21.                 d1(fn) = fn
    
22.                 For i = 3 To UBound(arr)
    
23.                     s = arr(i, 1)
    
24.                     If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
25.                     d(s)(fn) = arr(i, 7)
    
26.                 Next
    
27.             End If
    
28.         Next
    
29.         d1(xj(x)) = ""
    
30.     Next
    
31.     d1(xj(3)) = ""
    
32.     ReDim brr(1 To 1000, 1 To 100)
    
33.     For Each k In d.keys
    
34.         n = n + 1
    
35.         brr(n, 1) = n
    
36.         brr(n, 4) = k
    
37.     Next
    
38.     With sh
    
39.         .UsedRange.Offset(1).Clear
    
40.         .[a3].Resize(n, 4) = brr
    
41.         .[a2].Resize(1, d1.Count) = d1.keys
    
42.         .[a2].Resize(1, d1.Count).Interior.Color = 49407
    
43.         r = .Cells(Rows.Count, 1).End(3).Row
    
44.         arr = .Range("a2").Resize(r - 1, d1.Count)
    
45.         For i = 2 To UBound(arr)
    
46.             For j = 6 To UBound(arr, 2)
    
47.                 s = arr(i, 4)
    
48.                 If d.exists(s) Then
    
49.                     arr(i, j) = d(s)(arr(1, j))
    
50.                 End If
    
51.             Next
    
52.         Next
    
53.         With .Range("a2").Resize(r - 1, d1.Count)
    
54.             .Value = arr
    
55.             .Borders.LineStyle = 1
    
56.             .HorizontalAlignment = xlCenter
    
57.             .VerticalAlignment = xlCenter
    
58.         End With
    
59.         For x = 1 To 3
    
60.             c(x) = .Rows(2).Find(xj(x), , , , , 1).Column
    
61.         Next
    
62.         For i = 3 To r
    
63.             .Cells(i, c(1)) = Application.WorksheetFunction.Sum(.Cells(i, "f").Resize(1, c(1) - 5))
    
64.             .Cells(i, c(2)) = Application.WorksheetFunction.Sum(.Cells(i, c(1) + 1).Resize(1, c(2) - c(1) - 1))
    
65.             .Cells(i, c(3)) = .Cells(i, c(1)) + .Cells(i, c(2))
    
66.         Next
    
67.     End With
    
68.     Set d = Nothing
    
69.     MsgBox "OK！"
    
70. End Sub
    

复制代码

fzxba

提列及表名.zip (77.45 KB, 下载次数: 11)

2024-2-22 10:39 上传

点击文件名下载附件

ddz79101

fzxba 发表于 2024-2-22 10:39

谢谢老师！运行成功！