如何根据原始表关键列性别和组号按模板生成目标表自动加分页符

yzyyyyyyy · 发表于 2024-4-29 09:32

原始表：姓名，性别，组号，组内序号

模板：每组一页
目标表：各组间加分页符，姓名，性别，报名序号，（表头，性别组号人数红色字）

如何根据原始表关键列性别和组号按模板生成目标表自动加分页符.rar (20.05 KB, 下载次数: 8)

3190496160 · 发表于 2024-4-29 15:08

Sub 生成记录表()
Dim ar As Variant
Dim br()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With Worksheets("原始表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
ar = .Range("a1:l" & r)
End With
For i = 2 To UBound(ar)
If ar(i, 4) <> "" And ar(i, 7) <> "" Then
      zd = ar(i, 4) & "|" & ar(i, 7)
      If Not d.exists(zd) Then Set d(zd) = CreateObject("scripting.dictionary")
      d(zd)(i) = i
End If
Next i
With Sheets("目标表")
.UsedRange.Clear
rs = 1
For Each k In d.keys
      n = 0: mc = ""
      ReDim br(1 To UBound(ar), 1 To 6)
      For Each kk In d(k).keys
         mc = ar(kk, 10) & " " & ar(kk, 11) & " " & ar(kk, 12)
         zh = ar(kk, 7)
         n = n + 1
         br(n, 1) = n
         For j = 2 To 4
            br(n, j) = ar(kk, j)
         Next j
         For j = 7 To 8
            br(n, j - 2) = ar(kk, j)
         Next j
      Next kk
      Sheets("模板").Rows("1:14").Copy .Cells(rs, 1)
      .Cells(rs + 1, 2) = "监考组组长： " & mc
      .Cells(rs + 1, 10) = "性别：" & Left(k, 1) & ",组号" & zh & "人数：" & n
   .Cells(rs + 4, 1).Resize(n, UBound(br, 2)) = br
   rs = rs + 14
Next k
End With
MsgBox "ok!"
End Sub

3190496160 · 发表于 2024-4-29 15:09

如何根据原始表关键列性别和组号按模板生成目标表自动加分页符.rar (27.54 KB, 下载次数: 8)

3190496160 · 发表于 2024-4-29 15:10

分页符没必要，只要事先设置好模板中的行高就行了

tanglf188 · 发表于 2024-4-29 15:23

插入分页符一般都是在主标题上方啊，不知楼主究竟想插在何处
插入分页符代码如下：
本示例在单元格 F25 上方添加水平分页符，在其左侧添加垂直分页符。
With ActiveSheet
.HPageBreaks.Add Range("F25")
.VPageBreaks.Add Range("F25")
End With

每张工作表最多有 1026 个水平分页符。

chxw68 · 发表于 2024-4-29 16:08

Sub test2()
Dim r%, i%
Dim arr, brr
Dim d As Object
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set d = CreateObject("scripting.dictionary")
With Worksheets("原始表")
r = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("a2:m" & r)
For i = 1 To UBound(arr)
xm = arr(i, 4) & "+" & arr(i, 7)
If Not d.exists(xm) Then
Set d(xm) = CreateObject("scripting.dictionary")
End If
d(xm)(i) = Empty
Next
End With
With Worksheets("目标表")
.ResetAllPageBreaks
.Cells.Clear
r = 1
End With
With Worksheets("模板")
For Each aa In d.keys
ReDim brr(1 To 10, 1 To 6)
m = 0
For Each bb In d(aa).keys
m = m + 1
brr(m, 1) = m
brr(m, 2) = arr(bb, 2)
brr(m, 3) = arr(bb, 3)
brr(m, 4) = arr(bb, 4)
brr(m, 5) = arr(bb, 7)
brr(m, 6) = arr(bb, 8)
Next
x = d(aa).keys()(0)
.Range("a1") = arr(x, 5) & "八年级体育过程性评价成绩记录表"
With .Range("b2")
.Value = "监考组组长：（" & arr(x, 10) & "）（" & arr(x, 11) & "）（" & arr(x, 12) & "）"
With .Characters(Start:=7, Length:=Len(.Value) - 6).Font
.ColorIndex = 3
.Color = -16776961
End With
End With
With .Range("j2")
.Value = "性别：" & arr(x, 4) & Space(1) & "人数：" & m
.Font.ColorIndex = 3
End With
.Range("g3") = arr(x, 10)
.Range("i3") = arr(x, 11)
.Range("k3") = arr(x, 12)
.Range("a5").Resize(UBound(brr), UBound(brr, 2)) = brr
.Range("a1:m15").Copy Worksheets("目标表").Cells(r, 1)
r = r + 14
With Worksheets("目标表")
.HPageBreaks.Add before:=.Rows(r)
End With
Next
End With
End Sub

复制代码

chxw68 · 发表于 2024-4-29 16:08

参与一下。

Excel2119 · 发表于 2024-5-2 10:11

VBA批量添加分页线（为批量打印做准备）
https://club.excelhome.net/thread-1682874-1-1.html

		自动登录	找回密码
密码			免费注册

[求助] 如何根据原始表关键列性别和组号按模板生成目标表自动加分页符

评分

评分

评分

评分