也许许多人没看到，这是个动态表头。而且有这种需求的人都是只用于打印，因为通常管理档案的表格，没人会把档案号放在个位置，即占地方又不方便查找。所以，这个表只能用于打印。
楼主， 这个前段时间帮一个朋友解决类似问题, 是个工资台帐。它的表头会在打印每一页时会根据当前页的表内容实现动态变化，如果您需要类似操作，请把数据样品(别太多，几行则可)发我邮箱cells8@163.com吧
=========================================================================
就楼主的具体问题，下面实现动态表头并执地打印的是VBA代码:
Sub PrintTab()
Dim i As Long
Dim cs As Single
Dim p As String
Dim arr
cs = 0
p = Left(Sheet2.Cells(2, 1), 18)
Sheet1.Cells(4, 2).Resize(44, 3).ClearContents
For i = 2 To Sheet2.Range("A65536").End(xlUp).Row
arr = Sheet2.Cells(i, 2).Resize(1, 3)
Sheet1.Cells(cs + 4, 2).Resize(1, 3) = arr
cs = cs + 1
If Left(Sheet2.Cells(i + 1, 1), 18) <> p And i + 1 <= c Then
Sheet1.Cells(2, 3) = p
Sheet1.PrintOut From:=1, To:=1
cs = 0
p = Left(Sheet2.Cells(i + 1, 1), 18)
键橘 Sheet1.Cells(4, 2).Resize(44, 3).ClearContents
End If
空和 If cs > 43 Then
Sheet1.Cells(2, 3) = p
Sheet1.PrintOut From:=1, To:=1
cs = 0
Sheet1.Cells(4, 2).Resize(44, 3).ClearContents
End If
Next
End Sub
-------------------------------------------------------------------------------
实现原理: 一个数据表，一个模板表. 模板表上只有一页。 把数据从数据表上依次装载到模板表. 装满一页或档案号更换前, 修改表头并对模板表执行打印。 然后清空模板表继续装数据表数据，直接所有数据装载到模板表并执行打印动作。
=====================================================================
给 提问者 的意见:
因为您有几万条的数据，手工去完成这些打印操作会非常麻烦，所以您的问题我是特别认识对待的。 5月4日晚上您把文件样品交给我，我连夜就帮你写的程序代码，同时还进行了打印测试，以确保代码执行的准确性。 然后，自从把文件发给你之后，您就再沓无音信。刚看过你的个人中心，6小时前，你还在线。
我不得不在此提点儿意见，这也算是代表所有答友们给提问者的一点意见：
1. 如果我们的回答，没有解决您的问题，希望能积极联系，以便快速解斗亮盯决问题。
2. 如果我们的回答有幸解决了您的问题，也希望尽快给最佳答案。一这是对我们付出劳动最好的肯定，二是让有同类问题的朋友们尽快看到正确答案。
3. 我觉着提问者来知道提出关心的问题，有责任就答友们的回答及时沟通，正确答案及时认定。而且，我认为“我的问题解决了”就放任提问自生自灭，是对积极解答您问题人的一种极不尊重。
（贴主，因为这个提问还没结束，上边的话不代表是说您，我说了是代表所有答友们给提问者的一点意见）
======================================================================
5月9日晚收到贴主的答复，再复本贴：
需要把数据生成具体每一张表格，放在一个工作表。并且表格与表格间有分页
追加程序代码CreateTAB如下:
Sub CreateTab()
Dim i, c, k As Long
Dim cs As Single
Dim p As String
Dim arr
c = Sheet2.Range("A65536").End(xlUp).Row
cs = 0
k = 1
p = Left(Sheet2.Cells(2, 1), 18)
Application.ScreenUpdating = False
Sheet1.Cells(4, 2).Resize(44, 3).ClearContents
Sheet4.UsedRange.EntireRow.Delete
For i = 2 To c
arr = Sheet2.Cells(i, 2).Resize(1, 3)
Sheet1.Cells(cs + 4, 2).Resize(1, 3) = arr
cs = cs + 1
If Left(Sheet2.Cells(i + 1, 1), 18) <> p And i + 1 <= c Then
Sheet1.Cells(2, 3) = "档案号：" & p
'Sheet1.PrintOut From:=1, To:=1
Sheet1.[B1].Resize(47, 3).Copy Sheet4.Cells(k, 1)
k = k + 48
Sheet4.Cells(k, 1).PageBreak = xlPageBreakManual
cs = 0
p = Left(Sheet2.Cells(i + 1, 1), 18)
Sheet1.Cells(4, 2).Resize(44, 3).ClearContents
End If
If cs > 43 Then
Sheet1.Cells(2, 3) = "档案号：" & p
'Sheet1.PrintOut From:=1, To:=1
Sheet1.[B1].Resize(47, 3).Copy Sheet4.Cells(k, 1)
k = k + 48
Sheet4.Cells(k, 1).PageBreak = xlPageBreakManual
cs = 0
Sheet1.Cells(4, 2).Resize(44, 3).ClearContents
End If
Next
Application.ScreenUpdating = ture
End Sub
经本人测试，上述在03版上执行没有问题.