求助工资明细打印问题

明天，你好82

求助关于工资明细打印问题，请看附件


补充内容 (2024-11-16 07:41):
求高手解决！！！

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") = ""
    
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") = ""
    
20.         For i = 1 To UBound(arr)
    
21.             If arr(i, 2) = k Then
    
22.                 m = m + 1
    
23.                 d2(arr(i, 1)) = ""
    
24.                 For j = 1 To 9
    
25.                     brr(m, j) = arr(i, a(j))
    
26.                 Next
    
27.                 sm = sm + arr(i, 10)
    
28.             End If
    
29.         Next
    
30.             .Cells(2, cl).Value = d2.Count & "天": .Cells(2, cl + 1).Value = k
    
31.             .Cells(2, cl + 8) = sm
    
32.             .Cells(4, cl).Resize(m, 9) = brr
    
33.             If dy Mod 3 = 0 Then
    
34.             .Range("a1:ad47").PrintOut
    
35.             ElseIf dy = dic.Count Then
    
36.             .Range("a1:ad47").PrintOut
    
37.             End If
    
38.             cl = cl + 10
    
39. Next
    
40. End With
    
41. Set dic = Nothing
    
42. End Sub
    

复制代码

limonet

看到有下无回，害怕。

Qs18

试试.........

chengyunpan

参与一下，循环打印方式实现！！！！！！！！

明天，你好82

Qs18 发表于 2024-10-22 18:13
试试.........

请看效果图，如果名字明细超过47行则占用下个数据位置，还请将边框添加上去，谢谢！

Qs18

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

自己试着加一下吧，代码可以录制宏得到

明天，你好82

Qs18 发表于 2024-10-23 15:16
自己试着加一下吧，代码可以录制宏得到

这个有点复杂，录制没用

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.             .Cells(2, cl).Value = d2.Count & "天": .Cells(2, cl + 1).Value = k
    
32.             .Cells(2, cl + 8) = sm
    
33.             .Cells(4, cl).Resize(m, 9) = brr
    
34.             .Cells(4, cl).Resize(m, 9).Borders.LineStyle = xlContinuous
    
35.             If dy Mod 3 = 0 Then
    
36.             
    
37.             .Range("a1:ad47").PrintOut
    
38.             ElseIf dy = dic.Count Then
    
39.             .Range("a1:ad47").PrintOut
    
40.             End If
    
41.             cl = cl + 10
    
42. Next
    
43. End With
    
44. Set dic = Nothing
    
45. End Sub
    

复制代码

Qs18

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