这个表格里面数据最多生成11行

chxw68

参与一下。

SGD1

chxw68 发表于 2024-3-29 10:19
参与一下。

就是这种效果，非常感谢百忙之中给予指导！谢谢，谢谢

ykcbf1100

不用工作表函数了，改用按钮

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.3.29
   
2.     Dim arr, brr, d
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     Set sh = ThisWorkbook.Sheets("委托")
   
7.     xm = sh.[f4].Value
   
8.     arr = Sheets("数据库").Range("a1").CurrentRegion
   
9.     b = [{4,4,5,10,9,8,11}]
   
10.     r1 = 10 '//起始行号
    
11.     p = 11  '//间隔行数
    
12.     For Each sht In Sheets
    
13.         If sht.Name <> sh.Name And sht.Name <> "数据库" Then
    
14.             sht.Delete
    
15.         End If
    
16.     Next
    
17.     For i = 2 To UBound(arr)
    
18.         s = arr(i, 22)
    
19.         If Not d.exists(s) Then
    
20.             Set d(s) = CreateObject("Scripting.Dictionary")
    
21.         End If
    
22.         d(s)(i) = i
    
23.     Next
    
24.     m = d(xm).Count
    
25.     ReDim brr(1 To m, 1 To 7)
    
26.     For Each kk In d(xm).keys
    
27.         n = n + 1
    
28.         For j = 1 To UBound(b)
    
29.             brr(n, j) = arr(kk, b(j))
    
30.         Next
    
31.     Next
    
32.     On Error Resume Next
    
33.     For i = 1 To m Step p
    
34.         x = x + 1
    
35.         ReDim zrr(1 To p, 1 To 7)
    
36.         For k = 1 To p
    
37.             For j = 1 To 7
    
38.                 zrr(k, j) = brr(i + (k - 1), j)
    
39.             Next
    
40.         Next
    
41.         sh.Copy after:=Sheets(Sheets.Count)
    
42.         Set sht = ActiveSheet
    
43.         With sht
    
44.             .Name = xm & IIf(m <= p, "", "（" & x & ")")
    
45.             .DrawingObjects.Delete
    
46.             .Cells(r1, 2).Resize(p, 7) = zrr
    
47.             If m < p Then .Cells(r1 + n, 2) = "以下空白"
    
48.         End With
    
49.     Next i
    
50.     Set d = Nothing
    
51.     Application.ScreenUpdating = True
    
52.     MsgBox "OK！"
    
53. End Sub
    

复制代码

chengyunpan

之前做了一个，几乎和你的一模一样，但又不同一个账号发出来的。
你之份数据，好像还有缺项，管线号没见有，所以就只能做成这样子了。


万能批量软件用于楼主的案例

软件简介：   
     真正的软件级别，VBA通用软件，用于批量打印、拆分，用于特殊需求的录入、打印等等。不需改代码，就可以万能套用。复杂的数据引用、格式要求都能简单解决。
      单个、少量、批量操作（打印、拆分等）或者选择性操作都一样方便。
      核心很简单，就是用“=”号引用对应数据列，并作简单设置，一学就会，很容易套用到工作中遇到的实际案例。
       界面超级简单，千篇一律，傻瓜式操作。
      每个案例都仅是此软件的一个小应用，学会一个案例作参考就能一里通百里用，欢迎大家测试使用，更期待能提出宝贵意见。
     软件免费，并附简易教程，需要做简单设计才能吻合到实际案例。也可以联系作者提供设计服务，能为你提供完美的整体解决方案。
      文件就是软件！！！

SGD1

ykcbf1100 发表于 2024-3-29 19:55
参与一下。。。

也很好用，非常感谢

SGD1

chengyunpan 发表于 2024-3-29 20:28
之前做了一个，几乎和你的一模一样，但又不同一个账号发出来的。
你之份数据，好像还有缺项，管线号没见有 ...

好的大佬，我摸索一下感谢

1013182120

ykcbf1100 发表于 2024-3-29 19:55
不用工作表函数了，改用按钮

你好 我照着您的代码改了个自己用，但是想把图片里面保存单号和没收单号从“数据表”的第8列和9列，赋值给委托“移交表的第3行4列和第4行4列”要怎么添加进去。麻烦您给看下。

lanjialing

根据你的描述，我是否可以这样理解：要求按数据库表的委托单号进行分类分页，每类每页采集相同委托单号11行数据，每页按你的设计模板表生成，不足11行以“以下空白”字样结束。

ykcbf1100

1013182120 发表于 2024-3-30 10:42
你好 我照着您的代码改了个自己用，但是想把图片里面保存单号和没收单号从“数据表”的第8列和9列，赋值 ...

结构发生了变化，你上附件看看吧。