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

SGD1

这个表格里面只能按照数据库数据最多生成11行，假如我将委托单编号改成003，就放不下了，我想实现：数据不够11行时候，在B列最后一个数据后单元格显示“以下空白”四个字，超过11行时，自动复制A1:H22这个模版，粘贴至A23,保证模板格式不变，自动再往下填下数据，如果2页装不下数据再自动生成第3页，以此类推（是11的倍数数据的话不用加“以下空白”4个字）


新手小白第一次发帖求助各位大神，希望大神能帮帮忙

ykcbf1100

需求描述不够清楚，比如：要分页时，表名如何确定

SGD1

ykcbf1100 发表于 2024-3-29 09:00
需求描述不够清楚，比如：要分页时，表名如何确定

大神 附件表格打开应该好理解一点，分页时，表名应该还是一样的吧，就是在Sheet2里面复制第一页往下粘贴，数据还根据输入的委托编号自动填充

SGD1

ykcbf1100 发表于 2024-3-29 09:00
需求描述不够清楚，比如：要分页时，表名如何确定

里面我也弄了一部分代码，麻烦大哥给指导一下

limonet

用数组吧，本想用getrows,但是WPS不一定能运行。等大佬ykcbf1100的代码。

ykcbf1100

limonet 发表于 2024-3-29 09:41
用数组吧，本想用getrows,但是WPS不一定能运行。等大佬ykcbf1100的代码。

你先试一下啊，我写了一部分，暂时没时间了，要出去一下。

limonet

ykcbf1100 发表于 2024-3-29 09:43
你先试一下啊，我写了一部分，暂时没时间了，要出去一下。

他不一定能运行，不写了。

SGD1

limonet 发表于 2024-3-29 09:41
用数组吧，本想用getrows,但是WPS不一定能运行。等大佬ykcbf1100的代码。

我也有office365呢，

SGD1

ykcbf1100 发表于 2024-3-29 09:43
你先试一下啊，我写了一部分，暂时没时间了，要出去一下。

感谢大哥

chxw68

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2.     Dim r%, i%
   
3.     Dim arr, brr(), crr()
   
4.     Dim hg(1 To 22)
   
5.     If Target.Count > 1 Then
   
6.         Exit Sub
   
7.     End If
   
8.     If Target.Address = "$F$4" Then
   
9.         bh = Target.Value
   
10.         With Worksheets("数据库")
    
11.             .AutoFilterMode = False
    
12.             r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.             arr = .Range("a2:v" & r)
    
14.             m = 0
    
15.             For i = 1 To UBound(arr)
    
16.                 If arr(i, 22) = bh Then
    
17.                     m = m + 1
    
18.                     ReDim Preserve brr(1 To m)
    
19.                     brr(m) = i
    
20.                 End If
    
21.             Next
    
22.         End With
    
23.         If m = 0 Then
    
24.             MsgBox "没有符合条件数据！"
    
25.             Exit Sub
    
26.         End If
    
27.         With Worksheets("委托")
    
28.             r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
29.             If r > 22 Then
    
30.                 .Rows("23:" & r).Delete
    
31.             End If
    
32.             For i = 1 To 22
    
33.                 hg(i) = .Rows(i).RowHeight
    
34.             Next
    
35.         End With
    
36.         r = 23
    
37.         For k = 1 To UBound(brr) Step 11
    
38.             ReDim crr(1 To 11, 1 To 8)
    
39.             For i = 1 To Application.Min(11, UBound(brr) - k + 1)
    
40.                 crr(i, 1) = k + i - 1
    
41.                 crr(i, 2) = arr(brr(k + i - 1), 4)
    
42.                 crr(i, 3) = arr(brr(k + i - 1), 4)
    
43.                 crr(i, 4) = arr(brr(k + i - 1), 5)
    
44.                 crr(i, 5) = arr(brr(k + i - 1), 10)
    
45.                 crr(i, 6) = arr(brr(k + i - 1), 9)
    
46.                 crr(i, 7) = arr(brr(k + i - 1), 8)
    
47.                 crr(i, 8) = arr(brr(k + i - 1), 11)
    
48.             Next
    
49.             If i <= 11 Then
    
50.                 crr(i, 2) = "以下空白"
    
51.             End If
    
52.             With Worksheets("委托")
    
53.                 .Range("a10").Resize(UBound(crr), UBound(crr, 2)) = crr
    
54.                 .Range("a1:h22").Copy .Cells(r, 1)
    
55.                 For i = 1 To UBound(hg)
    
56.                     .Rows(r + i - 1).RowHeight = hg(i)
    
57.                 Next
    
58.                 r = r + 22
    
59.             End With
    
60.         Next
    
61.         With Worksheets("委托")
    
62.             .Range("a1:h22").Delete shift:=xlUp
    
63.         End With
    
64.     End If
    
65. End Sub
    

复制代码