Sub 複製新表()

Application.ScreenUpdating = False

Dim arr()

tr = 1

Dim i, j, k

For i = 2 To Sheets("班主任資訊").Range("A65536").End(xlUp).Row

Sheets("打印表").Rows("7:65536").Select

Selection.Delete Shift:=xlUp

tr = 1

rr = Sheets("學生資訊彙總").Range("A65536").End(xlUp).Row

ReDim arr(1 To rr, 1 To 16)

For j = 4 To Sheets("學生資訊彙總").Range("A65536").End(xlUp).Row

If Sheets("學生資訊彙總").Cells(j, 2) & Sheets("學生資訊彙總").Cells(j, 3) & _

Sheets("學生資訊彙總").Cells(j, 4) = Sheets("班主任資訊").Cells(i, 1) & Sheets("班主任資訊").Cells(i, 2) & Sheets("班主任資訊").Cells(i, 3) Then

For c = 1 To 16

arr(tr, c) = Sheets("學生資訊彙總").Cells(j, c)

Next

tr = tr + 1

End If

Next j

Sheets("打印表").[a7].Resize(tr, 16) = arr

Sheets("打印表").Range("A3") = "思茅區倚象鎮" & Sheets("班主任資訊").Cells(i, 5) & "村委會"

Sheets("打印表").Range("K3") = "倚象鎮" & Sheets("班主任資訊").Cells(i, 1)

……

……

……

詳細程式碼，傳給你。