求助工资明细打印问题

Qs18

试试..........

明天，你好82

Qs18 发表于 2024-10-23 16:14
试试..........

边框线是有了，但是当有名字数据超过47行，应该是继续写入到下一个名字的位置

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. a = [{1,3,4,5,6,7,8,9,10}]
   
6. With Sheet1
   
7.     arr = .Range("a4:j" & .Cells(Rows.Count, 1).End(3).Row)
   
8.     ReDim brr(1 To UBound(arr), 1 To 9)
   
9.     For i = 1 To UBound(arr)
   
10.         dic(arr(i, 2)) = i
    
11.     Next
    
12. End With
    
13. cl = 2
    
14. With Sheet2
    
15. .Range("b2:ad2,b4:ad1000") = "": .Range("b4:ad1000").Borders.LineStyle = xlNone
    
16. For Each k In dic.keys
    
17.     dy = dy + 1
    
18.     d2.RemoveAll: m = 0: sm = 0
    
19.     If cl > 23 Then cl = 2: .Range("b2:ad2,b4:ad1000") = "": .Range("b4:ad1000").Borders.LineStyle = xlNone
    
20.    
    
21.         For i = 1 To UBound(arr)
    
22.             If arr(i, 2) = k Then
    
23.                 m = m + 1
    
24.                 d2(arr(i, 1)) = ""
    
25.                 For j = 1 To 9
    
26.                     brr(m, j) = arr(i, a(j))
    
27.                 Next
    
28.                 sm = sm + arr(i, 10)
    
29.             End If
    
30.         Next
    
31.             If m <= 43 Then
    
32.             .Cells(2, cl).Value = d2.Count & "天": .Cells(2, cl + 1).Value = k
    
33.             .Cells(2, cl + 8) = sm
    
34.             .Cells(4, cl).Resize(m, 9) = brr
    
35.             .Cells(4, cl).Resize(m, 9).Borders.LineStyle = xlContinuous
    
36.             Else
    
37.             
    
38.             .Cells(2, cl).Value = d2.Count & "天": .Cells(2, cl + 1).Value = k
    
39.             .Cells(2, cl + 8) = sm
    
40.             .Cells(4, cl).Resize(43, 9) = brr
    
41.             .Cells(4, cl).Resize(43, 9).Borders.LineStyle = xlContinuous
    
42. 
    
43.             
    
44.              cl = cl + 10
    
45.              If cl > 23 Then cl = 2: .Range("b2:ad2,b4:ad1000") = "": .Range("b4:ad1000").Borders.LineStyle = xlNone
    
46.              rww = 3
    
47.              For rr = 44 To m
    
48.                 rww = rww + 1
    
49.                 .Cells(rww, cl).Resize(1, 9) = Application.Index(brr, m, 0)
    
50.              Next
    
51.              .Cells(4, cl).Resize(m - 43, 9).Borders.LineStyle = xlContinuous
    
52.             End If
    
53. 
    
54.             If dy Mod 3 = 0 Then
    
55.             
    
56. '            .Range("a1:ad47").PrintOut
    
57.             ElseIf dy = dic.Count Then
    
58. '            .Range("a1:ad47").PrintOut
    
59.             End If
    
60.             cl = cl + 10
    
61. Next
    
62. End With
    
63. Set dic = Nothing
    
64. End Sub
    

复制代码

Qs18

试试............

Qs18

试试............

明天，你好82

Qs18 发表于 2024-10-23 17:49
试试............

快要达到我想要的效果了，只是提取数据不对，烦请再次修改下，谢谢！

明天，你好82

Qs18 发表于 2024-10-23 16:14
试试..........

可以再帮我研究下吗？

明天，你好82

明天，你好82 发表于 2024-10-23 14:21
请看效果图，如果名字明细超过47行则占用下个数据位置，还请将边框添加上去，谢谢！

有没有大佬能帮我解决下这个问题