G7 (複製到各處)=VLOOKUP(\$P3,學生名冊!\$C:\$E,2+(COLUMN(A1)>1),)

Option Explicit
Sub TEST()
Dim Brr, i&, xR As Range, Z, T\$, j%, Find As Range
Set Z = CreateObject("Scripting.Dictionary")
Brr = Range([學生名冊!F1], [學生名冊!A65536].End(3))
For j = 4 To 6
T = Trim(Brr(1, j))
If T = "" Then GoTo j01
Set Find = [模版套表!B5:X7].Find(T, Lookat:=xlWhole)
If Find Is Nothing Then MsgBox "找不到 " & T & " 項目": Exit Sub
Z(Find.Value) = j: Set Z(Find & "/ad") = Find(, 6).Resize(, 2)
j01: Next
With Sheets("結果")
.Activate: .UsedRange.EntireRow.Delete: Set xR = .[A1]
For i = 2 To UBound(Brr)
[模版套表!D3] = Brr(i, 1): [模版套表!K3] = Brr(i, 2): [模版套表!P3] = Brr(i, 3)
For j = 1 To Z.Count - 1 Step 2: Z.Items()(j).Value = Brr(i, Z.Items()(j - 1)): Next
[模版套表!1:15].Copy xR: Set xR = xR(16)
[模版套表!1:15].Copy xR: xR(5, 28) = "第二聯自留": Set xR = xR(16)
[模版套表!1:14].Copy xR: xR(5, 28) = "第三聯收據": Set xR = xR(15)
xR.PageBreak = xlPageBreakManual
Next
.UsedRange.Interior.ColorIndex = xlNone
.PageSetup.PrintArea = "PrintArea"
MsgBox "執行完成"
End With
End Sub

Option Explicit
Sub TEST()
Dim Brr, i&, xR As Range, Z, T\$, j%, Find As Range
'↑宣告變數:&是長整數,\$是字串變數,%是短整數,沒有指定的是通用型變數
Set Z = CreateObject("Scripting.Dictionary")
'↑令Z變數是 字典
Brr = Range([學生名冊!F1], [學生名冊!A65536].End(3))
'↑令Brr變數是 以工作表儲存格值帶入的二維陣列
For j = 4 To 6
'↑設順迴圈j從4 到6
T = Trim(Brr(1, j))
'↑令T變數是1列j迴圈欄Brr陣列值
If T = "" Then GoTo j01
'↑如果T變數是空字元就跳到標示 j01位置繼續執行
Set Find = [模版套表!B5:X7].Find(T, Lookat:=xlWhole)
'↑令以T變數搜尋範圍儲存格值全同的儲存格
If Find Is Nothing Then MsgBox "找不到 " & T & " 項目": Exit Sub
'↑如果找不到!就跳出提示,結束程式執行
Z(T) = j: Set Z(Find & "/ad") = Find(, 6).Resize(, 2)
'↑令Z字典記錄"學生名冊"表欄號,令以Z字典記錄"模版套表"表儲存格
j01: Next
With Sheets("結果")
.Activate: .UsedRange.EntireRow.Delete: Set xR = .[A1]
'↑令激活結果表,令舊資料整列刪除,令xR變數是(物件)儲存格[A1]
For i = 2 To UBound(Brr)
'↑設順迴圈從2到 Brr陣列縱向最大索引列號
[模版套表!D3] = Brr(i, 1): [模版套表!K3] = Brr(i, 2): [模版套表!P3] = Brr(i, 3)
'↑令迴圈列班級/座號/姓名 各欄帶入結果表
For j = 1 To Z.Count - 1 Step 2: Z.Items()(j).Value = Brr(i, Z.Items()(j - 1)): Next
'↑設順迴圈將 書籍費/輔導費/其他 各欄帶入結果表
[模版套表!1:15].Copy xR: Set xR = xR(16)
[模版套表!1:15].Copy xR: xR(5, 28) = "第二聯自留": Set xR = xR(16)
[模版套表!1:14].Copy xR: xR(5, 28) = "第三聯收據": Set xR = xR(15)
'↑令複製 "模版套表"表資料列到結果表指定儲存格
xR.PageBreak = xlPageBreakManual
'↑令設定 手動分頁
Next
.UsedRange.Interior.ColorIndex = xlNone
'↑令結果表儲存格底色為無色
'↑令添加 名稱,設定儲存格範圍
.PageSetup.PrintArea = "PrintArea"
'↑設定列印範圍
MsgBox "執行完成"
End With
End Sub

>>> Range(.[A1], xR(0, 28)).name = "'" & .Name & "'!Print_Area" .... 直接定義名稱為〔列印範圍〕，且定義名稱最好冠上工作表名稱
>>> .PageSetup.PrintArea = "PrintArea"  .... 有了上一行, 這行可省略, PageSetup會拖慢速度, 非必要少用

謝謝前輩指導

[准大]:.Names.Add Name:="PrintArea", RefersTo:=Range(.[A1], xR(0, 28)).Name = "'" & .Name & "'!Print_Area"

.Names.Add Name:="PrintArea", RefersTo:=Range(.[A1], xR(0, 28)).Name = "'" & .Name & "'!Print_Area"

Range(.[A1], xR(0, 28)).name = "'" & .Name & "'!Print_Area"  ' .... 直接定義名稱為〔列印範圍〕，且定義名稱最好冠上工作表名稱

 歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)