Option Explicit
Sub TEST()
Application.DisplayAlerts = False
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
.Names.Add Name:="PrintArea", RefersTo:=Range(.[A1], xR(0, 28))
.PageSetup.PrintArea = "PrintArea"
MsgBox "執行完成"
End With
End Sub
發表於 2024-3-18 15:03
| 
