把明细数据按照模版拆分到同一个工作表的难题

jaxxcyh

1. Sub test()
   
2.     Dim arrInfo()
   
3.     arrInfo = Sheets("明细").[a1].CurrentRegion.Value
   
4.     Dim peopleNum$
   
5.     peopleNum = 0
   
6.     For i = 1 To UBound(arrInfo, 1)
   
7.         If arrInfo(i, 1) <> "" Then peopleNum = peopleNum + 1
   
8.     Next
   
9.     peopleNum = peopleNum - 1
   
10.    
    
11.     '删除多余的sheet表
    
12.     Application.DisplayAlerts = False
    
13.     For i = Sheets.Count To 4 Step -1
    
14.         Sheets(i).Delete
    
15.     Next
    
16.     Application.DisplayAlerts = True
    
17.    
    
18.     '创建新sheet表
    
19.     Sheets("模板").Copy after:=Sheets(Sheets.Count)
    
20.     Sheets(Sheets.Count).Name = "结果"
    
21.     Sheets("结果").Activate
    
22.    
    
23.     '根据人数创建表格
    
24.     For i = 1 To peopleNum
    
25.         If i > 1 Then
    
26.             Sheets("结果").Range("A1:L12").Copy Sheets("结果").Range("A" & (i - 1) * 13 + 1)
    
27.         End If
    
28.     Next
    
29.    
    
30.     '填充数据
    
31.     j = 2                      '明细数据起始行
    
32.     For i = 1 To peopleNum
    
33.         k = (i - 1) * 13 + 1       '填充表起始行
    
34.         Sheets("结果").Cells(k, 1).Value = "失业人员就业帮扶记录（" & "i" & "）号"
    
35.         Sheets("结果").Cells(k + 1, 2).Value = arrInfo(j, 1)  '姓名
    
36.         Sheets("结果").Cells(k + 1, 4).Value = arrInfo(j, 2)  '性别
    
37.         Sheets("结果").Cells(k + 1, 6).Value = arrInfo(j, 3)  '年龄
    
38.         Sheets("结果").Cells(k + 1, 8).Value = arrInfo(j, 4)  '学历
    
39.         Sheets("结果").Cells(k + 1, 10).Value = arrInfo(j, 5)  '是否城乡困难人员
    
40.         Sheets("结果").Cells(k + 1, 12).Value = arrInfo(j, 6)  '困难类型
    
41.         Sheets("结果").Cells(k + 2, 2).Value = arrInfo(j, 7)   '住址
    
42.         Sheets("结果").Cells(k + 2, 5).Value = arrInfo(j, 8)   '联系方式
    
43.         Sheets("结果").Cells(k + 2, 8).Value = arrInfo(j, 9)   '特长
    
44.         Sheets("结果").Cells(k + 2, 10).Value = arrInfo(j, 10)   '是否登记
    
45.         Sheets("结果").Cells(k + 2, 12).Value = arrInfo(j, 11)   '当前状态
    
46.         Sheets("结果").Cells(k + 3, 3).Value = arrInfo(j, 12)   '是否需要帮扶
    
47.         Sheets("结果").Cells(k + 3, 5).Value = arrInfo(j, 13)   '帮扶内容
    
48.         Sheets("结果").Cells(k + 3, 9).Value = arrInfo(j, 14)   '帮扶意向
    
49.         Sheets("结果").Cells(k + 3, 11).Value = arrInfo(j, 15)   '备注
    
50.    
    
51.         Do
    
52.             Sheets("结果").Cells(k + 7, 1).Value = arrInfo(j, 16)   '帮扶次数
    
53.             Sheets("结果").Cells(k + 7, 2).Value = arrInfo(j, 17)   '帮扶时间
    
54.             Sheets("结果").Cells(k + 7, 3).Value = arrInfo(j, 18)   '帮扶内容
    
55.             Sheets("结果").Cells(k + 7, 7).Value = arrInfo(j, 19)   '帮扶签字
    
56.             Sheets("结果").Cells(k + 7, 9).Value = arrInfo(j, 20)   '对本次帮扶
    
57.             Sheets("结果").Cells(k + 7, 10).Value = arrInfo(j, 21)   '需要的帮扶
    
58.             Sheets("结果").Cells(k + 7, 12).Value = arrInfo(j, 22)   '是否就业
    
59.             k = k + 1         '就业帮扶记录下移一行
    
60.             j = j + 1         '帮扶次数下移一条记录
    
61.             If j > UBound(arrInfo, 1) Then Exit Sub     '结束
    
62.         Loop Until arrInfo(j, 1) <> "" Or i > peopleNum
    
63.     Next
    
64. End Sub
    

复制代码

usedrange

参与一下，有些复杂

usedrange

1. Sub tt()
   
2.     Dim ar, i%, j%, m%, n%, nb%, mb, s%, non_mb, q%
   
3.     With Sheets("明细")
   
4.         q = .[p10000].End(xlUp).Row
   
5.         ar = .Range("a2:v" & q)
   
6.     End With
   
7.     Application.DisplayAlerts = False
   
8.     Application.ScreenUpdating = False
   
9.     With Sheets("模板")
   
10.         nb = 1
    
11.         Set non_mb = .[u1].Resize(12, 12) '设置空模板
    
12.         .[a1].Resize(12, 12) = non_mb.Value
    
13.         For i = 1 To UBound(ar)
    
14.             If ar(i, 1) <> "" Then
    
15.                 n = 2
    
16.                 If i <> 1 And ar(i, 1) <> "" Then
    
17.                     .[a1] = "失业人员就业帮扶记录（" & nb & "）号"
    
18.                     Set mb = .[a1].Resize(.[a20].End(xlUp).Row, 12)
    
19.                     nb = nb + 1
    
20.                     With Sheets("样例")
    
21.                         If i <> 4 Then
    
22.                             s = .[a100000].End(xlUp).Row + 2
    
23.                         Else
    
24.                             s = 1
    
25.                         End If
    
26.                         mb.Copy .Cells(s, 1).Resize(UBound(mb.Value), 12)
    
27.                     End With
    
28.                     .[a1].Resize(12, 12) = non_mb.Value
    
29.                     Set mb = Nothing
    
30.                 End If
    
31.                 For j = 1 To UBound(ar, 2)
    
32.                     If j < 7 Then
    
33.                         .Cells(2, n) = ar(i, j)
    
34.                         n = n + 2
    
35.                     ElseIf j < 12 Then
    
36.                         If j = 7 Then n = 2
    
37.                         .Cells(3, n) = ar(i, j)
    
38.                         If j = 7 Or j = 8 Then
    
39.                             n = n + 3
    
40.                         Else
    
41.                             n = n + 2
    
42.                         End If
    
43.                     ElseIf j < 16 Then
    
44.                         If j = 12 Then n = 3
    
45.                         .Cells(4, n) = ar(i, j)
    
46.                         If j = 13 Then
    
47.                             n = n + 4
    
48.                         Else
    
49.                             n = n + 2
    
50.                         End If
    
51.                     Else
    
52.                         If j = 16 Then n = 1
    
53.                         If j <> 19 Then
    
54.                             .Cells(8, n) = ar(i, j)
    
55.                             If j = 18 Then
    
56.                                 n = n + 6
    
57.                             ElseIf j = 21 Then
    
58.                                 n = n + 2
    
59.                             Else
    
60.                                 n = n + 1
    
61.                             End If
    
62.                         End If
    
63.                     End If
    
64.                 Next j
    
65.             Else
    
66.                 m = .[a30].End(xlUp).Row + 1
    
67.                 n = 1
    
68.                 For j = 16 To UBound(ar, 2)
    
69.                     If j <> 19 Then
    
70.                         .Cells(m, n) = ar(i, j)
    
71.                         If j = 18 Then
    
72.                             n = n + 6
    
73.                         ElseIf j = 21 Then
    
74.                             n = n + 2
    
75.                         Else
    
76.                             n = n + 1
    
77.                         End If
    
78.                     End If
    
79.                 Next j
    
80.             End If
    
81.             If i = q - 1 Then
    
82.                 .[a1] = "失业人员就业帮扶记录（" & nb & "）号"
    
83.                 Set mb = .[a1].Resize(.[a20].End(xlUp).Row, 12)
    
84.                 With Sheets("样例")
    
85.                     s = .[a100000].End(xlUp).Row + 2
    
86.                     mb.Copy .Cells(s, 1).Resize(UBound(mb.Value), 12)
    
87.                 End With
    
88.                 Set mb = Nothing
    
89.             End If
    
90.         Next i
    
91.     End With
    
92.     Set non_mb = Nothing
    
93.     Application.DisplayAlerts = True
    
94.     Application.ScreenUpdating = True
    
95. End Sub
    

复制代码

sunya_0529

WPS里的JSA练习一下——

sero61

这个案例貌似以前出现过   

zhangstone

感谢各位高手热心相助！

zhangstone

chxw68大神：
我现在又有一个模版，我参照您的代码做了些修改：如图。结果运行结果显示：下标越界。能帮我看看吗？我把代码比较放在附件的表中了。

chxw68

修改好了。你99%的修改都是对的，就是有个表格名称是“模版", 而代码中写的是"模板",所以就下标越界了。

vacre123

sunya_0529 发表于 2024-9-5 16:11
WPS里的JSA练习一下——

版主老师您好，我有幸看到您https://club.excelhome.net/threa ... tml?_dsign=950a30fe这个帖子里的图片，感觉非常好，请问可以分享一下吗？谢谢。

zhangstone

chxw68大神：
无比感谢您的热心帮助！