加载中…
加载中…
标签：
excel复制行高列宽excel复制格式excelvba技巧 |
分类： excel技巧 |
Excel VBA用Copy方法进行复制粘贴，往往会导致粘贴的数据没有了行高和列宽。那么，当我们要进行复制粘贴时，如何保证粘贴的数据保留原有的格式(包括行高列宽都不能变)。
笔者以一个模板设计为例进行说明。
模板表如图1 所示。
http://s7/mw690/001LTkQezy79UkTydzE36&690
图1
根据模板表生成表格的效果如图2所示。
http://s3/mw690/001LTkQezy79UkZISc232&690
图2
使用Copy方法复制粘贴，代码如下所示：
Sub Copy复制粘贴困惑()
Dim x As Integer
With Sheet2
'清空数据
.UsedRange.Clear
'恢复标准列宽
.Columns.ColumnWidth = .StandardWidth
'恢复标准行高
.Rows.RowHeight = .StandardHeight
End With
For x = 1 To 30 Step 15
'复制大标题区
Sheet1.Rows("3:4").Copy Sheet2.Rows(x)
'小标题区
'横向复制1份/纵向复制4份---粘贴份数由扩展区域Resize(1, 12)决定
Sheet1.Range("B5:D5").Copy Sheet2.Cells(x + 2, "B").Resize(1, 12)
'正文区
'横向复制5份/纵向复制4份---粘贴份数由扩展区域Resize(10, 12)决定
Sheet1.Range("B6:D7").Copy Sheet2.Cells(x + 3, "B").Resize(10, 12)
Next x
End Sub
运行代码效果如图3所示。
http://s16/mw690/001LTkQezy79UkZnsLB0f&690
图3
粘贴时为了保证行高和列宽一同被复制，可以先整行使用Copy方法进行复制粘贴，这样就可以保证行高一同被复制；使用PasteSpecial方法选择性粘贴，参数Paste设置为xlPasteColumnWidths即可保证列宽一同被复制，参数Paste设置为xlPasteFormats则只粘贴格式而不粘贴数据。
为了能一次性复制多份，粘贴区域的选择很重要，粘贴区域的行数=样本区域行数×横向份数，粘贴区域的列数=样本区域列数×纵向份数。比如示例中正文区样本为2行3列，现需要横向5份/纵向4份共20份粘贴正文区，则粘贴区域应为2行×5份=10行、3列×4份=12列，即10行12列的区域，所以示例粘贴区域为.Cells(x + 3, "B").Resize(10, 12)。如果粘贴区域设置不当将会出现不可意料的效果，请自行测试。
好了，按照上述方法将代码修改成如下所示，运行后即可得到如图2所示效果。
Sub 复制全部格式包括行高列宽()
Dim x As Integer
With Sheet2
'清空数据
.UsedRange.Clear
'恢复标准列宽
.Columns.ColumnWidth = .StandardWidth
'恢复标准行高
.Rows.RowHeight = .StandardHeight
End With
For x = 1 To 30 Step 15
'复制大标题区
Sheet1.Rows("3:4").Copy Sheet2.Rows(x)
'小标题区
'复制行高
Sheet1.Rows(5).Copy Sheet2.Rows(x + 2)
'纵向复制4份
Sheet1.Range("B5:D5").Copy Sheet2.Cells(x + 2, "B").Resize(1, 12)
'正文区
'横向复制行高5份
Sheet1.Rows("6:7").Copy
Sheet2.Rows(x + 3 & ":" & x + 12).PasteSpecial xlPasteFormats '选择性粘贴格式
'横向复制5份/纵向复制4份
Sheet1.Range("B6:D7").Copy
With Sheet2.Cells(x + 3, "B").Resize(10, 12)
.PasteSpecial xlPasteFormats '选择性粘贴格式
.PasteSpecial xlPasteColumnWidths '选择性粘贴列宽
End With
Next x
End Sub
标签：
登分系统excel登分find方法考试成绩录入模糊查找 |
分类： excel技巧 |
本程序下载下址
http://wenku.baidu.com/view/dbe60ce7482fb4daa48d4b85.html
登分是每次考试后不可少的工作，21世纪各种考试的成绩统计已经进入电脑时代，但登分工作却大多停留于“刀耕火种”年代——预先整理试卷、按座位号登分，重复数据手工查找……。笔者所在学校甚至还在使用最原始方法——评卷、拆卷、分班、登分。班级多，人数多，时间紧，不仅使得工作人员疲倦不堪，同时也出现不少的错误数据。鉴于此，笔者根据本校实际情况，用Excel VBA编了个程序，免去了按学号顺序登分之苦，也免去了登分前整理试卷之累，甚至避免了按记分册登分的查找不便之处，让教师可左手翻试卷，右手敲键盘登分，一气呵成。
程序需建立花名册（如图1）及登分（如图2）两个工作表，工作人员先在花名册工作表录入考生信息，如学号（或考号）、姓名、班级等，然后在登分工作表的第一列输入分数、第二列输入考生信息进行模糊查找，查找结果通过列表显示，你只需轻按键盘（Up、Down、Left、Right、Enter、Esc键）选择正确的学生信息即可快速录入。
http://s5/mw690/001LTkQegy71KBjY5WQ04&690
图1
http://s4/mw690/001LTkQegy71KBl5kd503&690
图2
程序代码简单，先在登分工作表新建两个 ActiveX 控件——文本框TextBox1和列表框ListBox1，然后为他们添加相关事件代码。
我们在工作表第二列激活的单元格里输入查询的关键字其实是一种错觉，实际上是用一个与单元格一模一样的文本框覆盖着单元格，其实输入到的是文本框内，为使文本框及列表框能随单元格的选择而相应改变，必须为工作表添加单元格激活事件代码：
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error Resume Next '设置容错语句，防止操作出错时卡住
Application.EnableEvents = False '禁用事件
If ListBox1.Visible Then ListBox1.Visible = False
If TextBox1.Visible Then TextBox1.Visible = False
ListBox1.Clear '清除列表
With Target '激活的单元格
If .Column = 2 And .Row <> 1 Then '属于第二列，并且不是第一行
'设置TextBox1跟随单元格，如大小、位置、填充颜色、字体等要一致
TextBox1.Top = .Top + 1
TextBox1.Left = .Left + 1
TextBox1.Width = .Width - 1
TextBox1.Height = .Height - 0.1
'设置ListBox1位置跟随单元格变化
If .Row > ActiveWindow.VisibleRange.Rows.Count + ActiveWindow.VisibleRange.Row - 5 Then
ListBox1.Top = .Top - ListBox1.Height
Else
ListBox1.Height = .Height * 5
ListBox1.Top = .Top + .Height + 1
End If
ListBox1.Left = .Left + .Width + 1
ListBox1.Width = .Width * (Sheet3.UsedRange.Columns.Count + 1)
TextBox1.BackColor = .Interior.Color
TextBox1.ForeColor = .Font.Color
TextBox1.Font.Size = .Font.Size
TextBox1 = .Value
TextBox1.Visible = True
ListBox1.Visible = True
TextBox1.Activate
Call TextBox1_Change
TextBox1.SelStart = 0
TextBox1.SelLength = 1000
End If
End With
Application.EnableEvents = True
End Sub
为了能随着输入查询关键字不断的进行模糊查找，需为TextBox1添加Change事件，并用Find方法实现查找功能。代码如下：
Private Sub TextBox1_Change()
Dim firstAddress As String, rng As Range, Arr() As String '声明需要用到的变量
TextBox1.Visible = True
ListBox1.Visible = True
ListBox1.Clear
TextBox1.TopLeftCell.Value = TextBox1.Text '激活的单元格内容与文本框一致
If TextBox1 = "" Then Exit Sub
K=-1
With Worksheets ("花名册").UsedRange
L = .Columns.Count + .Column – 1 '总列数
'按值模糊查找
Set rng = .Find(TextBox1.Text, LookIn:=xlValues, Lookat:=xlPart)
If Not rng Is Nothing Then '如果找到目标
firstAddress = rng.Address '记录第一个找到单元格的地址
Do '继续查找，直到找到的单元格地址等于刚才记录的单元格地址时停止
k=k+1
Redim Preserve Arr(k) '重新定义数组
'查找结果读入数组
Arr(k)= .Cells(rng.Row, 1)
For i = 2 To L
Arr(k)= Arr(k) & vbTab & .Cells(rng.Row, i)
Next
Set rng = .FindNext(rng) '查找下一个
Loop While rng.Address <> firstAddress
ListBox1.List = Arr '查找结果写入列表框
End If
End With
End Sub
为使文本框及列表框能响应Up、Down、Left、Right、Enter、Esc键，需为TextBox1和ListBox1添加KeyDown事件代码。
Private Sub ListBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next '设置容错语句，防止操作出错时卡住
Select Case KeyCode
Case 13 '回车Enter键
If ListBox1.ListCount > 0 Then
If ListBox1.Text = "" Then ListBox1.ListIndex = 0 '如果没有选中项目，默认选中第一个项目
Dim Arr
Arr = Split(ListBox1.Value, vbTab) '将选中的项目文本转换为数组
With TextBox1
.Visible = False
.TopLeftCell.Value = .Text '当前单元格内容为文本框内容
'将选中项目内容写入工作表
With .TopLeftCell.Offset(0, 1).Resize(1, UBound(Arr))
.Value = Arr
.Value = .Value
End With
.TopLeftCell.Offset(1, 0).Select '激活当前单元格的向下的一个单元格
End With
KeyCode = 0
End If
Case 37 'Left向左键
TextBox1.Activate '激活文本框以输入查询关键字
Case 27 'Esc取消
TextBox1.Visible = False
ListBox1.Visible = False
End Select
End Sub
Private Sub TextBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
On Error Resume Next
Dim Arr
With TextBox1
Select Case KeyCode
Case 38 'UP向上键
'激活当前单元格的上一单元格
.Visible = False
.TopLeftCell.Value = .Text
.TopLeftCell.Offset(-1, 0).Select
KeyCode = 0
Case 13 'Enter回车
'输入列表框第一个项目内容至工作表并激活当前单元格的下一单元格
If ListBox1.ListCount > 0 Then
Arr = Split(ListBox1.List(0), vbTab)
.Visible = False
.TopLeftCell.Value = .Text
With .TopLeftCell.Offset(0, 1).Resize(1, UBound(Arr))
.Value = Arr
.Value = .Value
End With
.TopLeftCell.Offset(1, 0).Select
KeyCode = 0
End If
Case 40 'Down向下键
'激活当前单元格的下一单元格
.Visible = False
.TopLeftCell.Value = .Text
.TopLeftCell.Offset(1, 0).Select
KeyCode = 0
Case 37 'Left向左键
'输入列表框第一个项目内容至工作表并激活当前单元格的左一单元格
.Visible = False
If ListBox1.ListCount > 0 Then
Arr = Split(ListBox1.List(0), vbTab)
.TopLeftCell.Value = .Text
With .TopLeftCell.Offset(0, 1).Resize(1, UBound(Arr))
.Value = Arr
.Value = .Value
End With
End If
.TopLeftCell.Offset(0, -1).Select
KeyCode = 0
Case 39 'Right向右键
ListBox1.Activate '激活列表框
Case 27 'Esc取消
.Visible = False
ListBox1.Visible = False
Selection.Select
End Select
End With
End Sub
为了能用鼠标双击点选项目实现输入，效果等同按下Enter键，需为ListBox1添加DblClick事件代码。
Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
On Error Resume Next '设置容错语句，防止操作出错时卡住
If ListBox1.ListCount > 0 Then
If ListBox1.Text = "" Then ListBox1.ListIndex = 0 '如果没有选中项目，默认选中第一个项目
Dim Arr
Arr = Split(ListBox1.Value, vbTab)
With TextBox1
.Visible = False
.TopLeftCell.Value = .Text
With .TopLeftCell.Offset(0, 1).Resize(1, UBound(Arr))
.Value = Arr
.Value = .Value
End With
.TopLeftCell.Offset(1, 0).Select
End With
End If
End Sub
登分结束后，可能会出现一些错误数据，如分数超科目满分、重复录入等，也可能出现录入分数而没录入学生信息或反之，还可能出现某几个学生没有录入的情况。程序设计了查错代码进行检查并给出检查结果，同时在登分工作表末录入未登分的学生信息。
Public Sub ChaCuo() '查错
On Error Resume Next '设置容错语句，防止操作出错时卡住
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'写入数组-----------
Dim R As Long '表格中行总数
Dim L As Integer '表格中列总数
Dim Arr '将表格写入数组
With Sheet2
With .UsedRange
R = .Rows.Count + .Row - 1
L = .Columns.Count + .Column - 1
End With
Arr = .Range(.Cells(1, 1), .Cells(R, L)).Value
.Protect Password:="freeholiday52uys" '保护工作表
End With
'-----------------------------------
Dim InBox As Integer
InBox = Application.InputBox(Prompt:="请输入“" & Arr(1, 1) & "”科满分：", Title:="请输入数字", Default:=100, Type:=1)
If InBox = 0 Then
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Exit Sub
End If
'登分表写入数组-----------
Dim Sht3R As Long '表格中行总数
Dim Sht3L As Integer '表格中列总数
Dim ArrSht3 '将表格写入数组
With Worksheets ("登分")
With .UsedRange
Sht3R = .Rows.Count + .Row - 1
Sht3L = .Columns.Count + .Column - 1
End With
ArrSht3 = .Range(.Cells(1, 1), .Cells(Sht3R, Sht3L + 1)).Value
End With
'-----------------------------------
'数据维护--------------------------
Dim x As Long, j As Long, x1 As Long, i As Long
Dim Str As String, StrKZ As String, StrKH As String, StrCF As String
Dim flag As Boolean
Dim Arr1() As Long '记录所有重复行号数组
Dim Arr2() As String '记录所有重复行号数组，用于写入sheet6
Dim k As Long 'Arr1下标
Dim m As Long 'Arr2 下标
Str = ""
StrKZ = ""
StrKH = ""
k = 0
ReDim Arr1(1 To 1)
m = 1
ReDim Arr2(1 To R, 0)
Arr2(1, 0) = "重复学生信息维护结果："
For x = 2 To UBound(Arr, 1)
'查登分错误********
If IsNumeric(Arr(x, 1)) = False Then '字符
Str = Str & Cells(x, 1).Address(False, False) & ","
ElseIf Len(Arr(x, 1)) = 0 Then '空值
If Len(Arr(x, 3)) > 0 Then
StrKZ = StrKZ & Cells(x, 1).Address(False, False) & ","
End If
Else '数字
Select Case Val(Arr(x, 1))
Case Is = -1, Is = -2, 0 To InBox
Case Else
Str = Str & Cells(x, 1).Address(False, False) & ","
End Select
End If
'******************
'学生信息************
If Arr(x, 3) = "" Then
If Len(Arr(x, 1)) > 0 Then
StrKH = StrKH & x & "," '空行
End If
Else
'重复行&&&&&&&&&&&
flag = True
For j = 1 To UBound(Arr1)
If Arr1(j) = x Then '判断行x是否已查找过
flag = False
Exit For '若Arr1数组存在x行则退出循环
End If
Next j
If flag Then 'x没查找过则
StrCF = ""
i = 0
For x1 = x + 1 To R
If Arr(x, 3) = Arr(x1, 3) And Arr(x, 1) <> Arr(x1, 1) Then
k = k + 1
ReDim Preserve Arr1(1 To k)
Arr1(k) = x1
StrCF = StrCF & x1 & ","
i = i + 1
Exit For '退出循环
End If
Next x1
If StrCF <> "" Then '记录查找到的行
m = m + 1
If i > 100 Then
Arr2(m, 0) = "与第" & x & "行信息重复的行>100行"
Else
Arr2(m, 0) = "与第" & x & "行信息重复的行：" & StrCF
End If
End If
End If
'&&&&&&&&&&&&&&&&&
'记录已登成绩的学生信息&&&&&&&&&&&&
ArrSht3(Val(Arr(x, 3)), Sht3L + 1) = "TRUE"
'&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
End If
'***************************
Next x
'----------------------------------------
'记录未登成绩学生信息--------------------
Dim Arr3() As String
j = 0
ReDim Arr3(1 To Sht3L + 1, 1 To 1)
For x = 2 To UBound(ArrSht3, 1)
If ArrSht3(x, Sht3L + 1) <> "TRUE" Then
j = j + 1
ReDim Preserve Arr3(1 To Sht3L + 1, 1 To j)
Arr3(1, j) = x
For x1 = 2 To Sht3L + 1
Arr3(x1, j) = ArrSht3(x, x1 - 1)
Next
End If
Next x
'----------------------------------------
'未登成绩学生信息写入登分表------------
With Worksheets ("登分")
.Cells(R + 1, 3).Resize(UBound(Arr3, 2), UBound(Arr3, 1)).Value = Application.Transpose(Arr3)
.Range("A2:B" & R + j).Locked = False
End With
'-------------------------------
'错误数据写入sheet6--------------------------
Dim LastRow As Long
With Sheet6 '错误数据表
.Visible = xlSheetVisible '显示工作表
.UsedRange.Clear
.Cells(1, 1).Value = "数据维护结果：" & Now()
.Cells(2, 1).Value = "分值错误的单元格：" & Str
.Cells(3, 1).Value = "分值为空的单元格：" & StrKZ
.Cells(5, 1).Value = "学生信息为空的行：" & StrKH
.Cells(7, 1).Resize(UBound(Arr2), 1).Value = Arr2 '学生信息重复行
Application.Goto .Cells(1, 1), True '将窗口滚动至该单元格，即该单元格位于当前窗口的左上方
.Activate
End With
MsgBox "数据维护完毕，请查看结果！漏登成绩的学生信息已写入《" & Sheet2.Name & "》的第" & R & "行至" & R + j & "行！", vbInformation, "提示信息…"
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
参考文献：
罗刚君，EXCEL 2010 VBA编程与实践 北京：电子工业出版社，2010.12
标签：
excel经验技巧vba成绩统计成绩分析考试成绩管理 |
分类： excel技巧 |
本软件下载地址
小学初高中考试成绩统计分析管理系统
http://wenku.baidu.com/view/4c148eea647d27284a735167.html
高中考试成绩统计分析管理系统（有文理班）
http://wenku.baidu.com/view/c6c8c3062cc58bd63086bd60.html
【摘要】为了保证学生成绩录入和处理的公平性，为了防止考试改卷中的不正当竞争，学校一般都会将同一年级的学生打乱，混合编班进行测试和录入分数。为了提高数据分析的效率，避免不必要的重复工作，本文利用Excel VBA编程方法轻松实现了不破坏原始表，且不受班数和人数限制的前提下，及时准确地对成绩进行处理和分析。
【关键词】教学成绩 统计 分析 Excel VBA
在学校的教学活动中，通过统计分析学生的考试成绩，以便确定学生的接受效果和教学的方法是否得当，为教学方法的改进提供依据，是每一位任课教师所要做的重要教学工作之一。有了Excel，我们可用不用躬着身、驼着背、拿着计算器一个一个算着学生的成绩了，大大提高工作效率、规范处理过程、减少差错。
为了保证学生成绩录入和处理的公平性，为了防止考试改卷中的不正当竞争，很多学校采用全年级混合编班考试，而统计成绩时，则是将已判分但未拆封的考卷统一交到教务处，按座位号顺序(每本考卷的自然顺序)统一录入成绩。也就是说，把同年级多个班的学生成绩统一录入到一个Excel工作表中，再分析统计出全年级各科成绩。这种情况下，想在不破坏原始工作表的情况下统计分析各科各班成绩，采用排序、筛选等人工干预完成统计是一件很枯燥、很繁琐、工作量很大的事。那么，能不能用相对比较简单的办法来解决问题呢?答案显然是肯定的。
Excel是微软公司的Microsoft office的组件之一，它可以进行各种数据的处理、统计分析，在学校工作中有着广泛的应用。例如花名册、座位表、登分表等的电子文档都是使用它来创建的。Excel不仅具有强大的制表功能，同时还内置了系统开发工具VBA。VBA是指Visual Basic for Application，它是在Office中广泛应用的宏语言，可以直接对Excel对象进行编程，从而提高Excel的利用效率。使用它可以增强Excel的自动化能力，使用户更高效地完成特定任务。因此，笔者空闲时用VBA编了个程序，轻松快速地统计分析成绩（如个人总分，按班或年级排名、总分、平均分、最高分、最低分、名次或分数段人数、年级或班级前XX名等，并可输出打印），不破坏原始工作表，不受班数和人数限制，可自定义作弊、缺考、0分是否参与统计分析，经实际应用，操作简单，方便实用。
程序分为排名、统计、查询、打印四大模块，设计完成后，工作人员只需导入原始成绩表：第一行为列标题且有班级一列和不合并单元格即可，其它不受任何限制（如存在空行或空列；可以任意增加删除科目；可以任意增加删除辅助列如：学号、年级、座位号等；而且各列位置任意；不受班数、人数、科目数限制，行列不受限制等，如图1）。在设置工作表中设置各科满分、优秀线、及格线、低分线、分数段、名次段、任课教师后，即可进行成绩统计、查询及打印输出。
http://s10/mw690/001LTkQegy71Jda0kdP69&690
图1
一、个人总分计算
因原始成绩表不限制科目数且各列位置任意，而且还想任意搭配科目计算总分，如：文综（政史地）、理综（理化生），为了方便缺考、作弊的统计，原始成绩表录入-2代表缺考，计0分、-1代表作弊，计0分，不能用自动求和公式SUM计算总分。本软件按照设置的总分科目采用循环方式计算总分。
http://s2/mw690/001LTkQegy71JdcveZH11&690
图2 总分科目
代码：利用VBA数组加快代码运行速度
Arr = Worksheets ("原始成绩").UsedRange.Value '将原始成绩表写入数组
Arr1 = Worksheets ("总分设置").UsedRange.Value '将总分设置表写入数组
For y = 2 To UBound(Arr1 ,2) '总分科目循环
ReDim Preserve ArrZF(1 To R, 1 To i)
ArrZF(1, i) = Arr1(1, y) '写入总分科目
For x = 2 To UBound(Arr,1) '循环学生
For j = 2 To UBound(Arr1,1) '循环单科科目
For k = 1 To UBound(Arr,2) '列标题
If Arr(1, k) = Arr1(j, y) And Val(Arr(x, k)) > 0 Then '该科成绩大于0分
ArrZF(x, i) = Val(ArrZF(x, i)) + Val(Arr(x, k)) '计算总分
End If
Next
Next
Next
Next
运行结果如图3：
http://s3/mw690/001LTkQegy71JdeoHrIa2&690
图3
二、排名
原始成绩表有可能录入-1、-2但又要按0分排名，除以年级为单位排名外还要能以班为单位排名，因此本软件不使用工作表排名公式Rank进行排名，而是将排序科目先降序排序再按顺序写入名次，排名操作窗口如图4。
http://s11/mw690/001LTkQegy71JdfU2OSaa&690
图4
年级排名代码：
For i = 0 To ListBox1.ListCount - 1 '循环排名科目
.UsedRange.Sort Key1:= ListBox1.List(i), Order1:=xlDescending, Header:=xlYes, Orientation:=xlSortColumns '对科目降序排序
.Columns(kmL + 1).Insert shift:=xlShiftToRight '科目列下一列插入排名列
Arr = .Range(.Cells(1, kmL), .Cells(Sht9R, kmL + 1)).Value '科目i及名次列写入数组
Arr(1, 2) = Arr(1, 1) & "级名次"
Rank = 1 '初始化名次
Arr(2, 2) = Rank '第1名
For x = 3 To UBound(Arr1,1) '循环Arr所有行，对非0分排名
If Val(Arr(x, 1)) < Val(Arr(x - 1, 1)) Then '满足小于关系
Rank = x – 1 '名次等于行号-1
End If
If Val(Arr(x, 1)) > 0 Then
Arr(x, 2) = Rank '写入名次
RankLast = Rank '记录最后一个名次
End If
Next x
For x = UBound(Arr1,1) To 2 Step -1
If Len(Arr(x, 1)) > 0 Then
Select Case Val(Arr(x, 1))
Case 0 '零分参与排名
If CheckBox4.Value Then
Arr(x, 2) = RankLast + 1
End If
Case -1 '作弊参与排名
If CheckBox6.Value Then
Arr(x, 2) = RankLast + 1
End If
Case -2 '缺考参与排名
If CheckBox5.Value Then
Arr(x, 2) = RankLast + 1
End If
Case Is > 0
Exit For
End Select
End If
Next x
Next i
班级排名先以班级及排名科目为关键字进行多条件排序，找出某班开始行号及结束行号，然后按上述方式循环班级所在行进行排名。代码如下：省略重复部分
For i = 0 To ListBox2.ListCount - 1 '循环排名科目
……
For x = 3 To UBound(Arr1,1)
'记录班级开始行号start,结束行号over****
start = x
over = 0
For x1 = start + 1 To Sht9R
If Arr1(x1, 1) <> Arr1(x1 - 1, 1) Then
over = x1 - 1
Exit For
End If
Next x1
If x1 > UBound(Arr1,1) Then
over = UBound(Arr1,1)
End If
'*********
For x1 = start + 1 To over '按班排名
……
Next x1
If over >= start Then
x = over
End If
Next x
Next i
运行结果如图5。
http://s1/mw690/001LTkQegy71Jdh3fI400&690
图5
三、统计各项指标
本软件以班级列统计应考人数，科目列统计该科实考人数，单元格为空不参与统计。以班级为关键字排序后通过For循环某科目列的各行，计算各班总分、平均分，统计优秀人数、及格人数、低分人数、各分数段及名次段人数、最高分、最低分。统计窗口如图6。
http://s7/mw690/001LTkQegy71Jdi4stMc6&690
图6
代码：
ArrSht6 = .UsedRange .Value '分数设置读入VBA数组
ArrSht7 = .UsedRange .Value '教师名单读入VBA数组
.UsedRange.Sort Key1:= "班级", Order1:=xlAscending, Header:=xlYes, Orientation:=xlSortColumns '对原始成绩表班级升序排序
ArrSht5 = .UsedRange .Value '原始成绩表读入VBA数组
For i = 0 To ListBox1.ListCount - 1 '循环统计科目
……
For x = 3 To UBound(ArrSht5,1)
……
'统计***********
For x1 = start + 1 To over '按班统计
If Len(ArrSht5(x1, Sht5kmL)) > 0 Then 'Sht5kmL为统计科目列号
Select Case Val(ArrSht5(x1, Sht5kmL))
Case Val(ArrSht6(3, Sht6kmL)) To Val(ArrSht6(2, Sht6kmL)) '优秀人数
CountYX = CountYX + 1
Sumbj = Sumbj + Val(ArrSht5(x1, Sht5kmL)) '班级总分
Case Val(ArrSht6(4, Sht6kmL)) To Val(ArrSht6(3, Sht6kmL)) '及格-优秀
CountJG = CountJG + 1
Sumbj = Sumbj + Val(ArrSht5(x1, Sht5kmL))
Case Val(ArrSht6(5, Sht6kmL)) To Val(ArrSht6(4, Sht6kmL)) '低分-及格
CountDJ = CountDJ + 1
Sumbj = Sumbj + Val(ArrSht5(x1, Sht5kmL))
Case 0 '零分
Count0 = Count0 + 1
Case 0 To Val(ArrSht6(5, Sht6kmL)) '低分
CountDF = CountDF + 1
Sumbj = Sumbj + Val(ArrSht5(x1, Sht5kmL))
Case -1 '作弊
Count1 = Count1 + 1
Case -2 '缺考
Count2 = Count2 + 1
End Select
If Val(ArrSht5(x1, Sht5kmL)) > kmMax Then
kmMax = Val(ArrSht5(x1, Sht5kmL)) '最高分
End If
If Val(ArrSht5(x1, Sht5kmL)) > 0 And Val(ArrSht5(x1, Sht5kmL)) < kmMin Then
kmMin = Val(ArrSht5(x1, Sht5kmL)) '最低分
End If
End If
Next x1
'*****************
'计算，记录****************
CountA = over - start + 1 '应考人数
CountB = CountYX + CountJG + CountDF + CountDJ '实考人数
CountJG = CountJG + CountYX '及格人数
If CountB > 0 Then
eve = Sumbj / CountB '平均分（0分，作弊，缺考不参与统计）
If CheckBox9.Value Then '0分参与统计
If Count0 > 0 Then
eve = Sumbj / (CountB + Count0) '平均分（0分参与统计）
CountB = CountB + Count0 '实考人数(含0分）
CountDF = CountDF + Count0 '低分人数(含0分）
kmMin = 0 '最低分
End If
End If
If CheckBox10.Value Then '作弊参与统计
If Count1 > 0 Then
eve = Sumbj / (CountB + Count1) '平均分
CountB = CountB + Count1 '实考人数
CountDF = CountDF + Count1 '低分人数
kmMin = 0 '最低分
End If
End If
If CheckBox8.Value Then '缺考参与统计
If Count2 > 0 Then
eve = Sumbj / (CountB + Count2) '平均分
CountB = CountB + Count2 '实考人数
CountDF = CountDF + Count2 '低分人数
kmMin = 0 '最低分
End If
End If
CountYXL = CountYX / CountB '优秀率
CountJGL = CountJG / CountB '及格率
CountDFL = CountDF / CountB '低分率
'统计结果写入数组，，，，，，，，，
tjL = tjL + 1
ReDim Preserve ArrTJ(1 To ArrbtCount, 1 To tjL)
ArrTJ(1, tjL) = ArrSht5(over, Sht5bjL) '班级
ArrTJ(2, tjL) = CountA '应考人数
ArrTJ(3, tjL) = CountB '实考人数
ArrTJ(4, tjL) = Sumbj '总分
ArrTJ(5, tjL) = eve '平均分
ArrTJ(6, tjL) = CountYX '优秀人数
ArrTJ(7, tjL) = CountYXL '优秀率
ArrTJ(8, tjL) = CountJG '及格人数
ArrTJ(9, tjL) = CountJGL '及格率
ArrTJ(10, tjL) = CountDF '低分人数
ArrTJ(11, tjL) = CountDFL '低分率
ArrTJ(12, tjL) = kmMax '最高分
ArrTJ(13, tjL) = kmMin '最低分
ArrTJ(14, tjL) = ArrSht7(Sht7bjR, Sht7kmL) '教师姓名
'，，，，，，，，，
End If
'********************
……
Next x
Next i
……
'年级数据统计************
tjL = tjL + 1
ReDim Preserve ArrTJ(1 To ArrbtCount, 1 To tjL)
ArrTJ(1, tjL) = "合计"
ArrTJ(13, tjL) = 200000
For x = 1 To UBound(ArrTJ, 2) - 1
ArrTJ(2, tjL) = Val(ArrTJ(2, tjL)) + Val(ArrTJ(2, x)) '应考人数
ArrTJ(3, tjL) = Val(ArrTJ(3, tjL)) + Val(ArrTJ(3, x)) '实考人数
ArrTJ(4, tjL) = Val(ArrTJ(4, tjL)) + Val(ArrTJ(4, x)) '总分
ArrTJ(6, tjL) = Val(ArrTJ(6, tjL)) + Val(ArrTJ(6, x)) '优秀人数
ArrTJ(8, tjL) = Val(ArrTJ(8, tjL)) + Val(ArrTJ(8, x)) '及格人数
ArrTJ(10, tjL) = Val(ArrTJ(10, tjL)) + Val(ArrTJ(10, x)) '低分人数
If Val(ArrTJ(12, x)) > Val(ArrTJ(12, tjL)) Then ArrTJ(12, tjL) = Val(ArrTJ(12, x)) '最高分
If Val(ArrTJ(13, x)) < Val(ArrTJ(13, tjL)) Then ArrTJ(13, tjL) = Val(ArrTJ(13, x)) '最低分
Next x
ArrTJ(5, tjL) = Val(ArrTJ(4, tjL)) / Val(ArrTJ(3, tjL)) '平均分
ArrTJ(7, tjL) = Val(ArrTJ(6, tjL)) / Val(ArrTJ(3, tjL)) '优秀率
ArrTJ(9, tjL) = Val(ArrTJ(8, tjL)) / Val(ArrTJ(3, tjL)) '及格率
ArrTJ(11, tjL) = Val(ArrTJ(10, tjL)) / Val(ArrTJ(3, tjL)) '低分率
'***************
名次段及分数段人数统计因频率不确定，不能用Select Case语句而改用循环统计。代码：
'分数段频数读入数组************
For x1 = 7 To 36
If Len(ArrSht6(x1, j)) > 0 Then
k = k + 1
ReDim Preserve ArrFSD(1 To 4, 1 To k)
ArrFSD(1, k) = ArrSht6(x1, j)
For m = 1 To Len(ArrFSD(1, k))
If IsNumeric(Mid(ArrFSD(1, k), m, 1)) = False Then
ArrFSD(2, k) = Val(Left(ArrFSD(1, k), m - 1)) '分隔符左侧
ArrFSD(3, k) = Val(Right(ArrFSD(1, k), Len(ArrFSD(1, k)) - m)) '分隔符右侧
Exit For
End If
Next m
End If
Next x1
'***************
……
'统计分数段或名次段***********
For x1 = start + 1 To over
For j = 1 To UBound(ArrFSD, 2)
If Val(ArrSht5(x1, Sht5kmL)) >= Val(ArrFSD(2, j)) And Val(ArrSht5(x1, Sht5kmL)) < Val(ArrFSD(3, j)) Then
ArrFSD(4, j) = Val(ArrFSD(4, j)) + 1
End If
Next j
Next x1
'***************
运行结果：
http://s13/mw690/001LTkQegy71JdjHyNK8c&690
图7
http://s14/mw690/001LTkQegy71JdkMBhb9d&690
图8
http://s9/mw690/001LTkQegy71JdlN5SU48&690
图9
http://s10/mw690/001LTkQegy71JdmIlChb9&690
图10
http://s6/mw690/001LTkQegy71JdnysKh25&690
图11
四、查询
本软件通过查询窗口巧妙设置排序关键字及高级筛选条件，以AdvancedFilter高级筛选方法实现多条件查询。可按姓名查询、按班级查询（分班）；按某学科（含总分）某分数段查询；按班内名次（年级名次）段查询（如某班前XX名、年级前XX-XX名）等，各种查询条件还可自由组合。对查询结果，可按某关键字排序后显示，如按班级排名升序可组合出某班全部或班前XX名、年级前XX名排名等，按年级排名升序可组合出年级前XX名排名或全部排名等。窗口如图12。
http://s5/mw690/001LTkQegy71Jdoxiza64&690
图12
代码：
.UsedRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheet2.Range("M1:Q2"), copytorange:=.Range("A2"), unique:=False '高级筛选
If OptionButton3 Then '排序
.UsedRange.Sort Key1:=ComboBox1.Text, Order1:=xlAscending, Header:=xlYes, Orientation:=xlSortColumns
ElseIf OptionButton2 Then
.UsedRange.Sort Key1:=ComboBox1.Text, Order1:=xlDescending, Header:=xlYes, Orientation:=xlSortColumns
End If
运行结果：
http://s14/mw690/001LTkQegy71JdpvwD3ad&690
图13
五、打印
各项统计表册生成完毕后，由于是每个科目或班级一张表，需要将这些表作为一个组才能一次性打印，而且可以选择打印部分科目或班级，否则操作比较麻烦，有违简洁高效的目的，因此，在打印和预览上，在界面用两个ListBox列表框提供选择需打印的工作簿及相应的工作表，程序智能根据不同的表格设置页面，当然也可以在界面更改页面设置，以适应打印输出。然后根据界面上的数据设置工作表页面，再对这些表利用数组一次性选择输出打印和预览。打印窗口如图14所示。
http://s7/mw690/001LTkQegy71JdqCWH4e6&690
图14
代码：
For i = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.Selected(i) = True Then
ReDim Preserve ArrSht(k)
ArrSht(k) = .Name '需打印工作表读入数组
k = k + 1
End If
Next
Worksheets(ArrSht).PrintOut '利用数组一次性输出打印
到此，VBA编写的考试成绩统计分析程序初步完成，加上稍许美化和容错处理，如图15所示，一个高效简洁的成绩统计程序就完成了。
图15
参考文献：
罗刚君，EXCEL 2010 VBA编程与实践 北京：电子工业出版社，2010.12
标签：
excel经验技巧考场编排座位编排vba试场桌贴 |
分类： excel技巧 |
中小学考场编排系统下载地址：百度网盘
百度文库下载地址：
学校考试考场编排软件 http://wenku.baidu.com/view/464023029ec3d5bbfc0a740f.html
【摘要】科学的考场座位编排方法可以从根本上杜绝学生考试时的串通舞弊现象，保证考试的公平、公正及其严肃性。本文结合自己的工作经验，利用Excel VBA编程方法轻松实现了同级各班考生随机排座、且前后左右座位不是同班同学，打印考场座位表、桌贴等功能。经实际应用，操作简单，方便实用。
【关键词】随机排座；考场编排；座位表；桌贴；VBA数组
在编排考场时，既要基于学校实际，如需考虑各考场人数、组数、每组人数等出现差异，充好利用好每一个考场；还要让同级各班考生被重新随机排序后基本均匀地散布到各个考场，基本做到同一考场内同一班的考生前后左右均不相邻，从根本上杜绝学生考试时的串通舞弊现象，保证考试的公平、公正及其严肃性。随着学校办学规模逐渐扩大和学生人数的增加，考场编排的工作量不断加大。面对Excel工作表内动辄上千的数据行，通过手工多次排序和复制粘贴数据完成考场编排工作显然太麻烦了。那么，能不能用相对比较简单的办法来解决问题呢?答案显然是肯定的。
Excel是微软公司的Microsoft office的组件之一，它可以进行各种数据的处理、统计分析，在学校工作中有着广泛的应用。例如花名册、座位表、登分表等的电子文档都是使用它来创建的。Excel不仅具有强大的制表功能，同时还内置了系统开发工具VBA。VBA是指Visual Basic for Application，它是在Office中广泛应用的宏语言，可以直接对Excel对象进行编程，从而提高Excel的利用效率。使用它可以增强Excel的自动化能力，使用户更高效地完成特定任务。因此，笔者空闲时用VBA编了个程序，轻松快速地编排考场，生成考场座位表、桌贴等，经实际应用，操作简单，方便实用。
一、考场编排
在中高考中各考场人数一般是30人，但基于笔者学校的实际，会出现各考场人数各异、组数各异及每组人数各异的情况。因此，编排考场前，工作人员必须将考生花名册（必须含班级）录入花名册工作表，考场基本信息（必须含考场号、各组人数等）录入考场设置工作表中，如下图所示。
http://s8/mw690/001LTkQegy71zxkbdwH27&690
花名册工作表
http://s8/mw690/001LTkQegy71zxntCZ107&690
考场设置工作表
编排考场时，为保证考生既要随机分布，又要均匀分布，在程序设计上多次使用了随机编排。
（一）、班级内部考生的随机编排。程序在G列（辅助列）对学生生成一次随机数，再以班级和随机数为关键字段进行排序，实现班级内学生顺序的随机性。
代码：
Randomize (Timer) '初始化随机数生成器
For x = 2 To Sht2R '花名册行循环
Cells(x, "G") = Rnd 'G列写入随机数
Next x
Worksheets("花名册").UsedRange.Sort Key1:="班级", Order1:=xlAscending, Key2:= "随机数", Order2:=xlAscending, Header:=xlYes, Orientation:=xlSortColumns '排序
运行结果如下图：
http://s9/mw690/001LTkQegy71zxrn3nOe8&690
（二）、各班人数均匀分配到各考场。程序自动从《花名册》及《考场设置》工作表获取班级人数、考生总人数及考场人数后，按比例取整的方式计算各班在各考场分配的人数，公式：各班在各考场分配的人数=班级人数*(考场人数/考生总人数)。再因取整余下的考生作二次分配。
代码：为提高程序运行速度，程序将各工作表数据读入VBA数组中处理。
For x = 2 To UBound(ArrKC, 1) '考场号循环
j = j + 1 '考场号列号
For i = 2 To UBound(RenShuFenPei, 1) '班级循环
RenShuFenPei(i, j) = Val(ArrBJ(i, 2)) * Val(ArrKC(i,9)) \ Val(ArrTJ(2, 2)) '按比例分配考生——班级人数*(考场设置的人数/考生总人数)
Next i
Next x
人数分配结果如下图：
http://s2/mw690/001LTkQegy71zxsOwx3d1&690
（三）、编排考场号。获得各班在各考场的人数后，对各班每考生按分配的人数编考场号，对二次分配考生编上"座位" & vbTab & "100"（键盘无法输入vbTab，可防错）。
代码：
m = 0
ArrSht2= Worksheets("花名册").UsedRange.Value '读入数组处理数据
For x = 2 To Sht2R 'x某班第一个考生行号
k = 0
'按分配人数按班编考场号***********
For x1 = 2 To UBound(RenShuFenPei, 1) '班级循环
If ArrSht2(x, Sht2BJL) = RenShuFenPei(x1, 1) Then '班级名相同
For y = 2 To UBound(RenShuFenPei, 2) '考场循环
For j = 1 To Val(RenShuFenPei(x1, y)) '该班x1该考场y分配的人数
ArrSht2(x + k + j - 1, Sht2L + 2) = RenShuFenPei(1, y) '考场号
ArrSht2(x + k + j - 1, Sht2L + 3) = j + Rnd '座位号(辅助列，处理前后同班)
Next j
k = k + Val(RenShuFenPei(x1, y)) '该班已编排的人数
Next y
Exit For
End If
Next x1
'*********************************
'该班剩余考生编辅助考场号*************
Do While k < Val(RenShuFenPei(x1, 2)) '(班级人数)该班未编考场号人数循环
ArrSht2(x + k, Sht2L + 2) = "座位" & vbTab & "100" '考场号（辅助列）
ArrSht2(x + k, Sht2L + 3) = Rnd '座位号(辅助列)
k = k + 1 '该班已编排的人数累加(含辅助)
m = m + 1 '年级编辅助考场号"座位100"的考生人数累加
Loop
'*********************************
x = x + k - 1 '该班结束的行号 = 开始行号+班级人数-1
Next x
将数据写入工作表，并以考场号和座位号为关键字段进行排序，这样二次分配的考生都汇集到一起，并且按座位号列生成的随机数随机排序。然后采用循环语句，将二次分配考生分配到每考场，如果该考场人数已满，则分配给下一考场。这样使得剩余考生还是能尽可能均匀的、随机的分布到各考场。
代码：
For x = 2 To UBound(ArrSht2, 1)
If ArrSht2(x, Sht2L + 2) = "座位" & vbTab & "100" Then
k = x '二次分配考生开始行号
Exit For
End If
Next x
x = k '开始行号
i = Int(KCshu * Rnd + 1) '随机产生第一个考生的考场号
Do While x < m + k '年级未编考场号的行号循环
If i Mod KCshu <> 0 Then
y = (i Mod KCshu) + 2
Else
y = KCshu + 2
End If
If Val(RenShuFenPei(11, y)) < Val(RenShuFenPei(12, y)) Then '已编排考生数<</span>该考场设置的考生数
ArrSht2(x, Sht2L + 2) = RenShuFenPei(3, y) '考场号
For j = 2 To UBound(RenShuFenPei, 1)
If ArrSht2(x, Sht2BJL) = RenShuFenPei(j, 1) Then '班级名相同
ArrBJL = j
Exit For
End If
Next j
RenShuFenPei(ArrBJL, y) = Val(RenShuFenPei(ArrBJL, y)) + 1 '该班ArrBJL该考场y分配的人数累加
ArrSht2(x, Sht2L + 3) = Val(RenShuFenPei(ArrBJL, y)) + Rnd '座位号(辅助列，处理前后同班)
RenShuFenPei(11, y) = Val(RenShuFenPei(11, y)) + 1 '考场已分配的人数累加
x = x + 1 '循环到下一行
End If
i = (i Mod KCshu) + 1 '考场号列号累加
Loop
（四）、前后左右同班处理。在上面编排考场号的代码“ArrSht2(x + k + j - 1, Sht2L + 3) = j + Rnd”用于初步处理前后同班问题。例如1、4、5、6、7、8、9、10班在第1考场均分配了6名考生，各班考生在座位号列都生成1.xxx、2.xxx、3.xxx、4.xxx、5.xxx、6.xxx样式的随机数，如下图1。再以考场号和座位号为关键字段进行排序后，初步实现前后无同班，如下图2。
http://s3/mw690/001LTkQegy71zxwBR86c2&690
图1
http://s8/mw690/001LTkQegy71zxyCY6Pa7&690
图2
程序再按蛇形排列座位的方法检查各座位前后左右是否有同班，如果遇有同班，程序通过循环将该考生与同考场其他考生调换座位，直到符合前后左右无同班后退出循环。
代码：
k = 2 '第一行为标题列，考生从第二行开始
Do While k <= UBound(ArrSht2, 1)
'座次按考场写入数组********
For x = 2 To UBound(ArrKC, 1) '考场号循环
If ArrSht2(k, Sht2L + 2) = ArrKC(x, 2) Then '找到考场
Exit For
End If
Next x
i = 0
For y = 3 To UBound(ArrKC, 2) - 1 '组循环
If Val(ArrKC(x, y)) > 0 Then '该组分配了人数
i = i + 1 '组数累加
For j = 1 To Val(ArrKC(x, y)) '该组人数
If i Mod 2 <> 0 Then ' 奇数组
RenShuFenPei(j, 2 * i - 1) = ArrSht2(k + j - 1, Sht2BJL) '班级
RenShuFenPei(j, 2 * i) = k + j - 1 '行号
Else ' 偶数组
RenShuFenPei(j, 2 * i - 1) = ArrSht2(k + Val(ArrKC(x, y)) - j, Sht2BJL) '班级
RenShuFenPei(j, 2 * i) = k + Val(ArrKC(x, y)) - j '行号
End If
Next j
k = k + Val(ArrKC(x, y)) '已编排的总人数(年级)+1
End If
Next y
'*************************
'处理前后左右同班***********
For m = 1 To MaxRen
For y = 1 To UBound(RenShuFenPei, 2) Step 2
If Len(RenShuFenPei(m, y)) > 0 And Len(RenShuFenPei(m, yR)) > 0 Then
If RenShuFenPei(m, y) = RenShuFenPei(m, yR) Or RenShuFenPei(m, y) = RenShuFenPei(mD, y) Then '左右或前后同班
For y1 = 1 To UBound(RenShuFenPei, 2) Step 2
Select Case RenShuFenPei(m1, y1)
Case ""
Case RenShuFenPei(m, y)
Case RenShuFenPei(mU, y)
Case RenShuFenPei(mD, y)
Case RenShuFenPei(m, yL)
Case RenShuFenPei(m, yR)
Case Else
Select Case RenShuFenPei(m, y)
Case RenShuFenPei(m1U, y1)
Case RenShuFenPei(m1D, y1)
Case RenShuFenPei(m1, y1R)
Case RenShuFenPei(m1, y1L)
Case Else
'改动座次表&&&&&&&&&
StrY = RenShuFenPei(m, y)
RenShuFenPei(m, y) = RenShuFenPei(m1, y1)
RenShuFenPei(m1, y1) = StrY
'&&&&&&&&&&&&&&&&&&
'改动考场编排表&&&&&&&&&&
For j = 1 To Sht2L
Temp1(0, j) = ArrSht2(RenShuFenPei(m, y + 1), j)
Next j
For j = 1 To Sht2L
ArrSht2(RenShuFenPei(m, y + 1), j) = ArrSht2(RenShuFenPei(m1, y1 + 1), j)
Next j
For j = 1 To Sht2L
ArrSht2(RenShuFenPei(m1, y1 + 1), j) = Temp1(0, j)
Next j
'&&&&&&&&&&&&
End Select
End Select
Next y
Next m
'***************
Loop
运行结果如图3所示：
http://s14/mw690/001LTkQegy71zxAuam1ed&690
图3
最后对各考生编上座位号，考场编排完成。
二、座位表、桌贴的生成与打印
考生座位表、桌贴等的制作总体上讲是对单元格填充的过程，因此代码比较简单。但由于存在各考场人数不同、组数不同及各组人数不同的情况，在算法上，需利用考场组数及各组人数，采用循环语句进行填充。代码详见上面的前后左右同班处理，运行结果如图3、图4所示。
http://s8/mw690/001LTkQegy71zxCSmFx37&690
图4
座位表及桌贴生成完毕后，由于是每个考场一张表，需要将这些表作为一个组才能一次性打印，而且可以选择打印部分考场，否则操作比较麻烦，有违简洁高效的目的，因此，在打印和预览上，在界面用两个ListBox列表框提供选择需打印的工作簿及相应的工作表，程序智能根据不同的表格设置页面，当然也可以在界面更改页面设置，以适应打印输出。然后根据界面上的数据设置工作表页面，再对这些表利用数组一次性选择输出打印和预览。
打印界面如图5所示。
http://s3/mw690/001LTkQegy71zxEI1Ka72&690
图5
代码：
For i = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.Selected(i) = True Then
ReDim Preserve ArrSht(k)
ArrSht(k) = .Name '需打印工作表读入数组
k = k + 1
End If
Next
Worksheets(ArrSht).PrintOut '利用数组一次性输出打印
桌贴打印时可能出现某考生信息横跨2页的情况，程序先获取打印工作表当前状态下每页的行数，整除每考生桌贴占用的行数（本例占用5行），得到每页不横跨2页每组的考生数，再乘以每考生桌贴占用的行数，即可得到每页的行数，通过循环语句手工重新指定分页符，使其符合打印要求。
代码：
ActiveWindow.View = xlPageBreakPreview '进入分页预览状态
.ResetAllPageBreaks '重设分页符（删除人工分页符），让工作表自动产生分页符
ShtFSTrows = ((Application.ExecuteExcel4Macro("INDEX(GET.DOCUMENT(64),1)") - TitleRows) \ 5) * 5 '每页行数=(自动分页时每页行数 \ 5 ) * 5
For m = 1 To CInt((.UsedRange.Rows.Count - TitleRows) / ShtFSTrows + 0.5) '总页数（向上取整）
.HPageBreaks.Add Before:=Cells(m * ShtFSTrows + .UsedRange.Row + TitleRows, 1) '手工指定分页符
Next m
ActiveWindow.View = xlNormalView '还原为常规视图
到此，VBA编写的考场编排程序初步完成，加上稍许美化和容错处理，如图6所示，一个高效简洁的考场编排程序就完成了。
http://s5/mw690/001LTkQegy71zxIiQUAd4&690
图6
参考文献：
钱建明，EXCEL VBA 在考场编排中的设计与实现 文章编号：1673-8454（2014）14-0065-05 《中国教育信息化》
罗刚君，EXCEL 2010 VBA编程与实践 北京：电子工业出版社，2010.12
标签：
漓江竹筏漓江大船漓江快艇漓江夜游漓江游览方式 |
分类： 阳朔旅游攻略 |
豪华游船：
漓江全程精华游航线（官方）：即桂林磨盘山码头或竹江码头——阳朔段航线，是漓江航区的精华部分，游览时长4.5小时左右。
船票价格：
竹江——阳朔水东门（豪华空调船）：平（旺）季季全票270元，半票135元；淡季全票240元，半票120元。提供中餐需另收取标准餐费35元/人。
磨盘山——阳朔龙头山（普通空调船）：平（旺）季全票210元，半票105元；淡季全票190元，半票95元。免费提供中式经济餐。
说明：
1.每年的4月至11月及春节长假为平（旺）季，每年的1月、2月、3月、12月为淡季。
2.儿童票价的规定：1.2—1.5米（含）的儿童可按相应票价的50%享受优惠票价，1.2米（含）以下儿童免票，1.5米以上儿童按全票价格购票游览。每一成人游客可免费携带身高不超过1.2米的儿童一人。超过一人时，应按超过的人数购买半价票。
购票方式：1、到桂林市漓江游览调度结算中心售票大厅咨询购买船票，售票大厅地址位于桂林市福旺苑38号（南门桥附近）。 2、在桂林市各旅行社及其营业部、各宾馆饭店总台委托订购船票。 3、在乘船码头售票处临时购买当天船票。4、登录漓江景区官网www.liriver.com.cn ,点击“在线购票”，根据需要选择预订购买。5、在阳朔驴友之家淘宝店预定船票（http://52uys.taobao.com），船票及桂林市内酒店接到码头车费打包销售，推荐。
交通指南：
上船码头距市中心30公里，市区没有公交车前往。市区到码头还需打车前往或是在市区参团游漓江。自驾车的朋友乘船到阳朔后还要返回乘船码头提车。磨盘山码头是内宾码头，阳朔下船码头是龙头山码头(走到西街还要15-20分钟)；竹江码头是外事码头，阳朔下船码头是水东门码头，上岸就是西街。
小贴士：坐大船游全程漓江是旅游团的传统方式，好处是能完整地游完漓江精华段，豪华舒适，也有利于观光或摄影，缺点是价格较高，中途不停留，无法很休闲地看风景，也无法在途中下船到岸上走走，而且两头两尾无景点，时间不自由。开船时间是早上九点半，要提前一天订票，市区各漓江售票点均为打包形式（船票+车费）。
桂林市内水上游航线（官方）：从龙船坪起航至上游木龙洞码头往返，沿途观赏市区两岸风光，游览时长1小时左右。
船票价格：全票65元，半票33元。
儿童票价的规定：1.2—1.5米（含）的儿童可按相应票价的50%享受优惠票价，1.2米（含）以下儿童免票，1.5米以上儿童按全票价格购票游览。每一成人游客可免费携带身高不超过1.2米的儿童一人。超过一人时，应按超过的人数购买半价票。
购票方式：在桂林市龙船坪码头售票处临时购买当天船票。
交通指南：乘公交车11路、33路、99路到南溪山下车，徒步前往龙船坪码头。
小贴士：可远眺斗鸡山、塔山、穿山、象鼻山、伏波山等桂林市内十大名山，坐船游览桂林市区风景更加休闲方便，不会像陆地游览那样一个个景区走进去看那么累。行程轻松惬意，免去爬山劳顿，尽享市内山水精华，特别携适合老人小孩一同出游的游客。
阳朔水上游航线（官方）：从阳朔县城水东门码头起航至普益往返，途径福利镇，沿途观赏阳朔下游风光，游览总时长3小时左右。
船票价格：全票160元，半票80元。
儿童票价的规定：1.1—1.4米（含）的儿童可按相应票价的50%享受优惠票价，1.1米以下儿童免票，1.4米以上儿童按全票价格购票游览。每一成人游客可免费携带身高不超过1.1米的儿童一人。超过一人时，应按超过的人数购买半价票。
购票方式：在阳朔水东门码头（外事）售票处临时购买当天船票。
小贴士：此航线常因乘客较少而取消航行，请做好两手准备，以免耽搁您的行程。
阳朔精华游航线（非官方）：即阳朔龙头码头——阳朔杨堤码头航段，是阳朔漓江航区的精华部分，游览时长4小时左右。此航线用官方游船，但并未交税给政府，故属非法营运。
船票价格：全票195元，半票100元。船票包含阳朔县城范围内酒店至龙头山码头车费。
儿童票价的规定：1.1—1.4米（含）的儿童可按相应票价的50%享受优惠票价，1.1米以下儿童免票，1.4米以上儿童按全票价格购票游览。每一成人游客可免费携带身高不超过1.1米的儿童一人。超过一人时，应按超过的人数购买半价票。
购票方式：1、在阳朔各旅行社及其营业部、各宾馆饭店总台委托订购船票。2、在阳朔驴友之家淘宝店预定船票（http://52uys.taobao.com）。
小贴士：此航线用返程官方游船，但并未交税给政府，故属非法营运，遇检查或乘客较少时暂停航行。
阳朔总统之旅航线（官方）：即从兴坪码头起航至渔村往返，游览时长约1小时。旅行团的最爱，本文不作介绍。
竹筏漂流：
阳朔漓江公园竹筏漂流航线（官方）：阳朔政府划定杨堤至兴坪漓江航区成立阳朔漓江公园景区，投入资金修建码头、徒步游步道、景区电瓶车道及购置环保电瓶车，出台相关法规规范排筏漂流，所有筏工归政府统一管理，筏工从船老板变为政府雇佣的工人，轮流到码头排队候客。
1、杨堤码头——兴坪码头航段，游览时长2小时左右。船票216元/人，空位费35元/位。
船家提供有偿增值服务：A、可提供冠岩码头——杨堤码头——兴坪码头漂流服务，冠岩——杨堤航段需增加约100元/筏的费用；B、可提供杨堤码头——兴坪（黄布滩）——杨堤码头往返漂流服务，返程需增加约80元/筏的费用。
2、杨堤码头——九马画山码头航段，游览时长约80分钟。船票118元/人，空位费25元/位。
船家提供有偿增值服务：A、可提供冠岩码头——杨堤码头——九马画山码头漂流服务，冠岩——杨堤航段需增加约80元/筏的费用；B、可提供杨堤码头——九马画山——杨堤码头往返漂流服务，返程需增加约60元/筏的费用。
3、兴坪码头——杨堤码头航段，游览时长2小时左右。船票216元/人，空位费35元/位。
船家提供免费增值服务：可提供兴坪码头——杨堤（浪石风光）——兴坪码头往返漂流服务。
4、兴坪码头——九马画山码头——兴坪码头往返航段，游览时长约70分钟。船票98元/人，空位费20元/位。
价格说明：
1.计费方式：按人数计费，一筏可坐4人（每一竹筏还可免票搭乘身高不超过1.3米的儿童2人），如不满4人，必须补空位费；如2位包筏，杨堤至兴坪，则计费为：216*2(门票与竹筏费)+35*2（2个空位费）=502元。依此类推。
2.漓江竹筏船票为通票(原价216元/人)，已包含阳朔漓江公园门票及景区电瓶车费(不含空位费)。
3.关于儿童票：漓江竹筏1.3米以下小朋友免票，1.3米（含1.3米）以上小朋友需购买成人票；另每一竹筏仅可免票搭乘身高不超过1.3米的儿童2人，超过2人时应按超过人数购成人票。
购票方式：1、在阳朔各旅行社及其营业部、各宾馆饭店总台委托订购船票。2、在乘船码头售票处临时购买当天船票（不推荐）。3、提前预约并委托口碑好的竹筏师傅订购船票。4、在阳朔驴友之家淘宝店预定船票（http://52uys.taobao.com）。
交通指南：
1、去杨堤码头（适合桂林或阳朔出发）： A、桂林出发，桂林火车站乘桂林至阳朔的普巴（1小时，10元），杨堤路口下车，转乘阳朔至杨堤码头的中巴（30分钟，3元）到杨堤码头下车。B、阳朔出发，阳朔汽车站乘阳朔至杨堤码头的中巴车（1小时，9.5元）抵达杨堤码头下车。
2、去冠岩（草坪）码头（适合桂林出发）：桂林汽车总站乘冠岩景区专线车（1小时，10元）
3、去兴坪码头（适合桂林或阳朔出发）：A、桂林出发，桂林汽车站乘桂林至兴坪的普巴（2个半小时，28元）抵达兴坪车站下车。B、阳朔出发，阳朔汽车站乘阳朔至兴坪的中巴车（45分钟，7元）抵达兴坪车站下车。
4、兴坪码头回阳朔：下船后可凭票免费乘电瓶车到兴坪车站，转乘兴坪至阳朔的中巴车（45分钟，7元）到阳朔汽车站。
小贴士：A、乘竹筏漂流漓江，才能真正亲山近水，与漓江近距离接触，可随时停靠拍照玩耍，尽情欣赏漓江造型各异的山和感受凉爽的漓江水。B、景区经营管理模式允许竹筏工自行揽客，以激发筏工的积极性，最好提前预约口碑好的筏工为自己服务并代为订购船票，不要直接去售票处购买船票，景区临时分配的筏工来撑筏就像完成任务一样，直接开到码头，没有讲解，也没有停靠。C、从码头出发的竹筏都要重新验票，往返漂增值服务并不能抵达终点码头再返程，通常在距离终点码头2到3公里处返航。D、如果您有时间，我不管您从哪个码头上船，但下船的码头一定要在兴坪，我建议您在兴坪古镇小住一晚，虽然，他并没有县城的繁华与热闹，住宿的条件也不是特别的好，但，可以使您的心灵更加的容易安静，您在这里会更加感到生活的悠闲。
阳朔漓江下游钻石水道竹筏漂流航线（私人）：阳朔码头——福利码头往返航段，游览时长2小时左右，约200元/筏，一筏可乘4-6人。
购票方式：1、在阳朔各旅行社及其营业部、各宾馆饭店总台委托订购船票。2、在乘船码头直接与筏工谈价购买船票。3、在阳朔驴友之家淘宝店预定船票（http://52uys.taobao.com）。
小贴士：如果说漓江上游是风韵少妇的话，下游就是一位等待开发的处女，上游游人如织，下游宁静怡人，老电影《刘三姐》拍摄取景地多在漓江下游水域。此段漓江竹筏还没纳入政府管理，不用交税及管理费，价格便宜，因不规范管理，筏工素质参差不齐，价格很混乱，砍价时要多留个心眼，不要只顾图便宜哦。
漓江快艇（私人）：
桂林市内水上游+全程漓江精华游（桂林市区天湖码头——阳朔龙头山码头），游览时长3小时左右。包船游览：4人船约1000元，7人船约1800元。
购票方式：1、在桂林市各旅行社及其营业部、各宾馆饭店总台委托订购船票。2、在乘船码头直接与船家谈价购买船票。
小贴士：快艇的感觉就是打破传统，换种方式游漓江，逍遥自在，随时出发，随时停下……开船时间由你您决定，白天随到随游，并且可以停船上岸拍照；不受乘船时间、停留地点限制，自由自在。上船地点——桂林市区天湖码头，无须到30公里外的游船码头上船。
夜游漓江：
夜游两江四湖航线（官方）：桂林市区环城水系航线，即文昌桥码头（上）--解放桥码头（下）或解放桥码头（上）--文昌桥码头（下）。游览时长90分钟左右。
船票价格：成人190元/人 （普通硬座船），儿童125元/人（普通硬座船）。
儿童票价的规定：儿童身高1.2米以下免票，身高在1.2-1.4米（含1.2米）需购儿童票，身高1.4米（含1.4米）以上需购成人票。
购票方式：1、在桂林市各旅行社及其营业部、各宾馆饭店总台委托订购船票。2、在乘船码头售票处临时购买当天船票。3、登录两江四湖景区官网www.glljsh.com ,点击“在线购票”，根据需要选择预订购买。4、在阳朔驴友之家淘宝店预定船票（http://52uys.taobao.com）。
交通指南：
文昌桥码头：位于文昌桥东南端桥底（华亭食府后面），乘23、16、2路公交车到文昌桥站下车可抵达。
解放桥码头：位于解放桥东南端桥底，该处有六匹铜马为标识，乘11、31、10、14、18路公交车可抵达（在解放桥那里看见一个很大的佳能广告牌处即是）。
小贴士：乘船游览可欣赏灯光映衬下的桂林环城水系夜景，过船闸和升船机，体验山水与城市的交相辉映，品味历史与人文的华美乐章；感悟千峰环野立，一水抱城流的千古绝唱。每年11月至次年2月进入漓江枯水季节，在此期间由于水上交通原因，将可能无法在漓江段近距离观赏象鼻山。开放时间：19:30-21:30，开放时间及发船频率会根据淡旺季和黄金周进行适当调整，详情请及时咨询景区服务热线：0773-2888802(周一至周五上午8：30-12:00 下午15:00-18:00)。
鱼鹰捕鱼表演（私人）：阳朔码头附近水域，游览时长约1小时左右。
船票价格：100元/人（大型竹筏）。
儿童票价的规定：儿童身高1.4米以下免票，身高1.4米（含1.4米）以上需购成人票。
购票方式：1、在阳朔各旅行社及其营业部、各宾馆饭店总台委托订购船票。2、在阳朔驴友之家淘宝店预定船票（http://52uys.taobao.com）。
交通指南：沿阳朔西街往漓江方向徒步，至西街尾左拐100米即到。
小贴士：乘船夜游漓江，暮色中奇峰夹岸，碧水莺回，江中渔火，夹岸舍灯，星星点点，诗意盎然。开出几公里，然后来回在漓江上游弋，游船侧开一盏小灯照明，江水清浅，可以清晰看到鱼鹰在水底潜游的景象，热爱大自然生命的人不容错过。私人性质，注意安全。
欢迎您来阳朔旅游，美丽热情的阳朔欢迎你！
相关阅读：
桂林阳朔漓江旅游攻略——印象简介篇
标签：
夜游漓江鱼鹰捕鱼鸬鹚捕鱼阳朔渔火节阳朔民俗 |
分类： 跟我游阳朔--阳朔人看阳朔 |
“茭草青青野水明，小船满载鸬鹚行。鸬鹚敛翼欲下水，只待渔翁口里声。船头一声鱼魄散，哑哑齐下波光乱。中有雄者逢大鱼，吞却一半余一半……”。古代诗人吴嘉纪的《捉鱼行》一文对鱼鹰捕鱼的描写。
http://s6/mw690/60c95b0egcef9a3e77925&690
来自淘宝小店的评价
鸬鹚的别名叫鱼鹰，这是一种体型较大的水禽，它的外形像鸭子，所以渔民又称它为水老鸭。在中秋月圆的夜晚，我荣幸参观了鱼鹰捕鱼表演,一则虽是阳朔本地人，但却少见鱼鹰捕鱼表演，二则想为淘宝小店拍些照片。
http://s1/mw690/60c95b0egcef96d5b4f90&690
这就是我们乘坐的大竹筏，可乘坐20余人
http://s16/mw690/60c95b0egcef96cafd9bf&690
悠闲的鱼鹰
http://s13/mw690/60c95b0egcef96cc533fc&690
偶见捕鱼者
我们坐的船是用10根PVC管做成的大竹筏，比起以前的机动渔船视野更开阔，船头边上整整齐齐站着几只鱼鹰，鱼鹰驯养有素，虽然它们没有被栓着，甚至河风吹得它们前仰后翻，但它们规规矩矩站立着。出发——船静静地滑行在江面上，四周一片巨大的黑，只有江上，几点渔火闪闪烁烁，微光映照着夜色的漓江，别是一番意境；周围耸立着的高山，只能看见些许轮廓，就象巨人默默无言。船行十几分钟，我们便来到一处河面开阔，水流平缓地带。这时，渔民开灯照亮江中河底，漓江水清可见底，渔民用竹竿拍击水面，并高喊“嘎嗨嗨，嘎哑哑“的号子，几只鱼鹰听到命令似的，扑通扑通钻进了水里。“哑哑齐下波光乱”，鱼鹰在水中一会扎猛子潜入水中，一会仰头浮出水面，灯光照在江面，波光粼粼。一会儿，水面上露出一个黑头，一条鱼被鱼鹰衔在嘴里，鱼尾在江面来回甩动，鱼鹰为什么没吞下去？渔民告诉我，鱼鹰喉下有一个皮囊，能暂存捕捉到的鱼，渔民为防止鱼鹰将捕到的鱼吞进胃里，出发捕鱼前，用绳子将皮囊扎住；因为如果鱼鹰先吃饱了，它就偷懒不潜水捕鱼了。渔民说也不能把所有的鱼鹰脖子都扎起来，因为只有看到其他同伴吃到鱼，那些被扎了脖子的鱼鹰才会更卖力捉鱼，如果全部扎起来，那就没有肯抓鱼的啦。我们看见鱼鹰捕到的鱼总是尾巴在摆动，原来它是吞不下去，这大概就是诗中所说的“吞却一半余一半”了。
http://s14/mw690/60c95b0egcef96cc2cb8d&690
鱼鹰捕鱼
http://s16/mw690/60c95b0egcef96cdd088f&690
开心一刻
有的鱼鹰捕了鱼，游到船边来送给主人，有的就不一定了，这时，渔翁就将竹篙伸过去，将鱼鹰钩过来。原来，每只鱼鹰脚上都系有一根短绳子，绳子尾端打一个结，而竹篙顶端安有个小弯钩，渔翁把竹篙伸向鱼鹰，很容易就钩到那根绳子，此时鱼鹰就顺势站到竹篙上，渔翁把鱼鹰挑到船上，轻轻翘开下颚，手沿着鱼鹰脖子往上一捋，鱼鹰就一股脑把鱼全部吐在竹箩里。渔民偶尔也会捡一条小鱼奖励一下它。
http://s1/mw690/60c95b0egcef96ca02e20&690
老渔翁，80多岁了哦
返程时，老渔翁还跟我说起三个渔民用鱼鹰捕鱼的故事呢。第一个渔民大大咧咧，把捆扎鱼鹰脖子的水草系得松松垮垮。结果，无论大鱼小鱼，几乎都被贪吃的鱼鹰给私吞了，能从鱼鹰嘴里抢下来的鱼少得可怜。捕不到鱼，自然卖不到钱。所以，几个月过去了，他仍是一只舟，数十只鱼鹰，贫穷依旧。第二个渔民则精于算计，他把捆扎鱼鹰脖子的水草系得严严实实。一开始还好，无论大鱼小鱼，几乎全都颗粒归仓。但没多久，鱼鹰因为吃不饱，先后都饿死了。最后，他只剩下一只孤零零的渔舟，比第一个渔民还凄惨。只有第三个渔民，他把捆扎鱼鹰脖子的水草系得不紧也不松。鱼鹰抓到小鱼，可以直接吞下，当作自己果腹的美餐；鱼鹰抓到大鱼，想吞也吞不下去，只好吐出，成为渔民换钱的资本。结果，这个渔民每天都有可观数量的鱼卖到集市上去，自然也就越来越富了。
http://s2/mw690/60c95b0egcef96d3113b1&690
捕获的鱼甚少
老渔翁还说到，现在漓江的鱼越来越少，靠这种方法打鱼过生活根本不可能，甚至连鱼鹰自己也吃不饱，每天渔民还得买鱼喂它们。今晚的这场表演总共才抓了几条小鱼。几年前当地渔民就打算把鱼鹰统统卖掉不再坚守这个行业了，但是后来经中央台采访后，当地政府为了保留这道漓江上的风景，决定每年补贴当地渔民几千块钱，同时将鱼鹰捕鱼开发成一项旅游观光项目以赚取额外收入，每年12月前后举办阳朔渔火节。因此现在这种原始的捕鱼技巧才保存下来。渔翁还说由于渔民的下一代大都外出打工，没人肯坚守这个老本行，因此这项技艺恐怕离失传不远了。渔民还提到其实漓江上其实还存在少量的野生鱼鹰，但是跟人工培育的生活习性有很大差异。
http://s12/mw690/60c95b0egcef96d38c28b&690
与鱼鹰合影
http://s7/mw690/60c95b0egcef96d74b216&690
亲近鱼鹰
渔船返航途中，渔民就把所有鱼鹰脖子上的束缚解除，让它们自己在江上捉鱼吃个够。整个表演持续了50分钟左右。
标签：
马玲国阳朔旅游腺样体肥大保守治疗猪蹄鸡爪汤 |
分类： 随想 |
可怜天下父母心，养儿才知为人父母苦。孩子的健康时刻牵动父母心，我儿2岁，去年春天我儿感冒鼻塞严重，吃了不少感冒药后不知什么时候痊愈的，但去年国庆后的一次感冒又鼻塞，却迟迟不见好转，11月带到桂林医专检查说是腺样体肥大，医生开了些药回家服用一周，感觉稍好了点，但效果不太明显，因要接待自助客游阳朔，也不想吃太多西药，改吃中药8天，中药效果更慢，加上儿子抗拒停了中药，老婆上网查询到一按摩法，说是火气大，要先去火，按摩了几天，鼻塞愈发严重，睡觉经常被憋气，翻来复去无法安静入睡。再次到医院开西药（头胞+氟雷他定）吃了半个月，不见好转，因小孩不满4岁，不适合手术治疗，医生建议不需吃药治疗，回家好好照顾孩子，等到4岁后视情况用手术治疗。天啊，2岁不到的孩子晚上不能好好的睡觉，而且还要坚持到4岁才能治疗，别说孩子受不了，就是当父母的也承受不了啊。
原以为小孩的小病小痛上医院打针吃药总能治好的，没想到我儿的腺样体肥大却找不到医生帮忙医治，这时我才感觉到事态的严重。晚上看到儿子因憋气涨红的脸，时常惊醒要爸爸妈妈抱着睡觉，大人小孩整个晚上都不得安宁，这可如何是好？我也开始了网上查询腺样体肥大保守治疗方法，但却很少，都是建议手术治疗的，更为可怕的是说腺样体肥大如果不及时治疗可能会出现腺样体容貌，但手术治疗风险也很大，一是要全麻，二是很容易复发。老婆查到太医养生介绍用猪蹄与鸡爪熬汤可治小儿的腺样体肥大，我在好大夫网站里查到深圳市人民医院的马玲国博士也可用滴鼻法保守治疗。从网上查刘太医养生，得知刘太医其实是一骗子，就是一卖锅的托，病急乱投医，我一边在网上向马博咨询治疗方法，一边立刻到淘宝网上购买了一个玻璃锅熬起了猪蹄鸡爪汤，一天三餐都喝汤，2天后就有了效果，感觉孩子憋气的次数变少了，马博的滴鼻法很多人使用都说效果不错，而且更加专业。但我发现这汤对孩子有用，加上一天滴鼻三次一个疗程一个月，孩子小应该不会主动配合，而且马博说的药在阳朔这个小县城也买不到，我决定放弃马博的滴鼻法而采用太医养生食疗法喝汤治疗。喝汤期间也有反复，稍为一感冒我儿鼻塞就会加重，在元月10日和龙年大年初6的两次感冒鼻塞很严重，好像又回到了原点，我和老婆两次都差点决定启用马博的滴鼻法一试，但都因为一下子无法配齐药而坚持喝汤配合吃感冒药，我儿又慢慢的好转了，至今还在喝猪蹄鸡爪汤，虽然没有达到常人那样轻松自如的且鼻呼吸，晚上睡觉还会打小呼噜，但已经可以一觉睡到大天亮了，免除了被憋气之苦。我觉得现在要做的是继续喝汤，然后要注意加强我儿的体质，减少感冒的次数。
附：猪蹄鸡爪汤熬制方法：
1、用料：粗壮的猪蹄处理干净（不必焯水，但孩子对味道特别敏感的，可以轻轻焯一下），用刀划烂，但不必切开，太费力了；两个猪蹄+4个鸡爪子即可。
其他什么调料也不要放，如葱姜蒜，辣椒，花椒大料，八角茴香，等等。盐也不要放。
2、投料：如果是不大失水的锅，1斤肉放1升水的比例就可以，这样出来的汤大概也是一升。但是不同的锅失水是不一样的，失水多的锅，自己摸索一下水量，争取1斤肉大概出一升汤即可。
3、熬制：开锅后熬制12小时，长些也没关系，只是多费些燃料或电。按照太医法最理想的温度是80度，实际上一般都是在刚有一点冒泡又冒不出来多少最好；开始火力可以稍大，但开锅后马上调小火，否则肉硬了，有效物质就熬不出来了。
4、工具：最好是玻璃锅，电加热的，养生群的养友们用的最多的是德朗电炖锅，它的优点是，玻璃：化学性质最稳定；火力恰到好处，基本不失水，不用担心干锅；底下加热，四周外露冷却，可以形成对流，最符合刘先生的要求；锅的图片如下：
http://s14/middle/60c95b0egb8e8796608dd&690
这个锅最好是网购，商店卖的很少，很难找。
5、捞汤和吃法：熬好断电后，去渣喝汤，需要准备细眼漏勺一个，把肉渣、骨渣去掉，汤冷却后去掉表层的油，或用吸管喝，避免油脂。
熬好的汤可以放冰箱冷藏，但最多不要超过三天，超过三天的部分，建议分份用保鲜袋装起来冷冻，用的时候化开；
盛汤的容易也不要用不锈钢容器。
喝汤前可以放些水果蔬菜调味，也可以加一点盐，但是不要用葱姜蒜辣椒花椒大料等前述调料。如果孩子不爱喝的话，还可以做菜、煮面条、熬粥用。
汤要饭前喝，三餐之前都喝，多喝一点没关系。喝汤后饭量会正常下降一点，可以减少热量的摄入，不必担心，补充了充足的蛋白质，不必担心孩子回营养不良。
6、配合工作：因为肉经过长时间熬制，维生素损失殆尽，所以要注意多喝点果汁，或足够的水果和未经高温处理的蔬菜。
此外注意要多吃粗粮，尽量减少细粮油脂的摄入量，晚上不要吃太多，尤其是难于消化的东西，保持一点饥饿感有助于肿块的消除。
油脂细粮会拱着不好的东西生长；有人说吃肉上火，吃肉确实有很多问题，刘先生也专门论述过，但喝肉汤恰好可以避肉毒，所以不必担心。不摄入动物蛋白质的话，硬蛋白会越加缺乏，病只会更重，或手术后继续复发，没完没了。
参考资料：
腺样体幼儿用猪蹄汤熬制方法：http://blog.sina.com.cn/s/blog_5253a7670100pg6y.html
好大夫马玲国医生个人网站：http://malingguo.haodf.com/
后续：很多人看到我写的博客后总想咨询我，因本人工作繁忙并没有接受QQ咨询，请谅解，如您想了解就请直接电话咨询，有空的时候我会接您的电话的。说实在话，我本人不是医生，完全不懂医术，老婆在网上查到的方法觉得没什么害处，也花不了多少钱，抱着试试的态度而已，孩子上幼儿园，经常感冒，有时鼻子通气良好，睡觉安然，有时又好像回到原点，我老婆经常在某个腺样体Q群里交流，又是按摩又是艾薰的等等很多方法都用过，2012年10月又去X光，结果还是堵了很多，气道很窄，还影响到耳朵，说是负压大，有中耳炎。医生建议尽早手术，我和老婆为此争论了好久，到底手续否，纠结啊！11月的一次发烧，连续打了5天点滴，鼻子塞得更严重，但烧退后，鼻子通气了，到现在感觉都还不错，所以也不再提手术之事了，猪脚汤还时不时的喝着。所以大家想问我这汤管用不，我真不知该怎么回答。有一网友告诉我用金霉素或红霉素眼药膏擦鼻子，擦了近2年擦好了，但我没试过，没这耐性天天擦，网友说只有想到了就帮擦，先把鼻子弄干净再擦，还是蛮麻烦的。如果您想了解如何做这猪脚汤建议您直接向原文作者咨询：http://blog.sina.com.cn/s/blog_5253a7670100pg6y.html，最后祝所有腺样体肥大患儿尽早康复。
后续1：一直保守治疗，但最终还是手术了，原因是腺样体引起中耳炎造成听力严重下降，再不做手术可能会影响孩子一辈子的听力，在医生的建议下于2016年9月（7岁）进行了手术治疗。手术过程没有想象中的恐怖可怕，采用等离子低温消融，全麻手术过程2小时，不出血，孩子恢复很快，全程没有任何痛苦。保守治疗不好的亲们不要纠结了，祝所有腺样体肥大患儿早日康复。
