合并Excel工作薄中成绩表的VBA代码，非常适合教育一线的朋友

这时候还需要把各个工作表合并到一起来形成一个汇总表。这时候比较麻烦也比较容易出错，因为各个表的学号不一定都是一致的、对齐的。因为可能会有人缺考，有人会考号涂错等等。特奉献以下代码，用于合并学生成绩表或者其它类似的表都可以。本代码特点在于不需要使用SQL或者Access等大头软件，只需要Excel就可以执行，非常方便，速度也不慢。转载请勿清除广告。
没有合适的局域网管理软件吗？你的网管工具够灵活够高效吗？看看这个networkmanagementsoftware。
"=============================================
"合并总表时，不参加计算的表格数目
"因为一般合并的总表放在最后一个工作表，要排除掉这个表。
ConstExcludeSheetCount=1
"主函数，因为用到了ADO，必须作如下引用才能运行本代码。
"工具>引用，引用ADO(MicrosoftActiveXDataObjects2.XLibrary)
"链接所有sheet到一个总表
"要合并的表的第一行必须是字段名称，不能是合并单元格
SubSQL_ADO_EXCEL_JOIN_ALL()
DimcnnAsNewADODB.Connection
DimrsAsNewADODB.Recordset
Dimi,k,shCountAsInteger
DimSQL,SQL2AsString,cnnStrAsString
Dims1,s2,s3,tmpAsString
DimwsAsWorksheet
ConstIDIdx=1
ConstScoreIdx=3
shCount=ActiveWorkbook.Sheets.Count
"获取所有考号
"EXCEL会自动去除重复数据
"SQL="(selectIDfrom[语文$])union(selectIDfrom[英语$])union(selectIDfrom[物理$])orderbyID"
SQL=""
Fori=1ToshCount-ExcludeSheetCount
s1="(SELECTIDFROM["&Sheets(i).Name&"$])"
Ifi=1Then
SQL=s1
Else
SQL=SQL&"UNION"&s1
EndIf
Next
"MsgBoxSQL
Setws=ActiveWorkbook.Sheets(shCount)
cnnStr="provider=microsoft.jet.oledb.4.0;ExtendedProperties="Excel8.0;HDR=yes;IMEX=1";datasource="&ThisWorkbook.FullName
cnn.CursorLocation=adUseClient
cnn.ConnectionString=cnnStr
cnn.Open
rs.OpenSQL,cnn,adOpenKeyset,adLockOptimistic
ws.Activate
ws.Cells.Clear
Fori=1Tors.Fields.Count
ws.Cells(1,i)=rs.Fields(i-1).Name
Next
ws.Range("A2").CopyFromRecordsetrs
Fori=1ToshCount-ExcludeSheetCount
Sheets(shCount).Cells(1,i+1)=Sheets(i).Name
Next
"EXCEL不支持UPDATE
"SQL="update[合并$]set语文="1""
"相当于内联接
"SQL="selecttt.ID,ta.scoreas语文,tb.scoreas英语from[合并$]AStt,[语文$]asta,[英语$]astb"
"SQL=SQL&"where(tt.ID=ta.ID)and(tt.ID=tb.ID)"
"左联接所有表格
"通过测试的语句
"SQL="selecttt.ID,ta.scoreAS语文,tb.scoreas英语from([合并$]ASttleftjoin[语文$]astaontt.ID=ta.ID)"
"SQL=SQL&"leftjoin[英语$]astbontt.ID=tb.ID"
SQL2="(["&Sheets(shCount).Name&"$]ASttLEFTJOIN["&Sheets(1).Name&"$]ASt1ONtt.id=t1.id)"
SQL="SELECTtt.ID,"
Fori=1ToshCount-ExcludeSheetCount
tmp="t"&i
SQL=SQL&tmp&".scoreAS"&Sheets(i).Name
Ifi<shCount-ExcludeSheetCountThenSQL=SQL&","
Ifi>1Then
SQL2="("&SQL2&"LEFTJOIN["&Sheets(i).Name&"$]AS"&tmp&"ONtt.id="&tmp&".id)"
EndIf
Next
s1=SQL&"FROM"&SQL2&"ORDERBYtt.ID"
MsgBoxs1
rs.Close
rs.Opens1,cnn,adOpenKeyset,adLockOptimistic
"清除表格
ws.Activate
Cells.Select
Selection.DeleteShift:=xlUp
Fori=1Tors.Fields.Count
ws.Cells(1,i)=rs.Fields(i-1).Name
Next
ws.Range("A2").CopyFromRecordsetrs
rs.Close
cnn.Close
Setrs=Nothing
Setcnn=Nothing
CallAddHeader
CallFindBlankCells
CallTableBorderSet
ws.Columns(1).AutoFit
ws.Cells(2,1).Select
MsgBox"Finished."
EndSub
"在表格第一行插入行，然后合并单元格，加上说明文字
SubAddHeader()
DimwsAsWorksheet
Dims1,s2AsString
shCount=ActiveWorkbook.Sheets.Count
Setws=Sheets(shCount)
Column=ws.UsedRange.Columns.Count
ws.Rows(1).Insert
s1=Chr(Asc("A")+Column-1)
s2="A1:"&s1&"1"
ws.Range(s2).Merge
ws.Rows(1).RowHeight=100
s1="说明"&Chr(13)&Chr(10)&_
"本总表为计算生成，把几个单科的客观题成绩合并在一起，避免手工处理时因考号不对齐而导致错位。"&Chr(13)&Chr(10)&_
"注意：如果某单科成绩表中存在相同考号，则总表中该考号的该科成绩是不准确的。"&Chr(13)&Chr(10)&_
"填涂错误的考号，一般出现在表里顶端或底端"
ws.Cells(1,1)=s1
ActiveSheet.Rows(1).RowHeight=80
"冻结窗格
ActiveSheet.Rows(3).Select
ActiveWindow.FreezePanes=True
ActiveWindow.SmallScrollDown:=0
EndSub
"设置表格边框
SubTableBorderSet()
ActiveSheet.UsedRange.Select
Selection.Borders(xlDiagonalDown).LineStyle=xlNone
Selection.Borders(xlDiagonalUp).LineStyle=xlNone
WithSelection.Borders(xlEdgeLeft)
.LineStyle=xlContinuous
.Weight=xlThin
.ColorIndex=xlAutomatic
EndWith
WithSelection.Borders(xlEdgeTop)
.LineStyle=xlContinuous
.Weight=xlThin
.ColorIndex=xlAutomatic
EndWith
WithSelection.Borders(xlEdgeBottom)
.LineStyle=xlContinuous
.Weight=xlThin
.ColorIndex=xlAutomatic
EndWith
WithSelection.Borders(xlEdgeRight)
.LineStyle=xlContinuous
.Weight=xlThin
.ColorIndex=xlAutomatic
EndWith
WithSelection.Borders(xlInsideVertical)
.LineStyle=xlContinuous
.Weight=xlThin
.ColorIndex=xlAutomatic
EndWith
WithSelection.Borders(xlInsideHorizontal)
.LineStyle=xlContinuous
.Weight=xlThin
.ColorIndex=xlAutomatic
EndWith
EndSub
"标记无分数的单元格，方便找出答题卡没有分数的学生
SubFindBlankCells()
Dimi,j,row,colAsInteger
"ActiveSheet.Cells(2,1).Interior.ColorIndex=15
row=ActiveSheet.UsedRange.Rows.Count
col=ActiveSheet.UsedRange.Columns.Count
Fori=2Torow
Forj=2Tocol
IfIsEmpty(ActiveSheet.Cells(i,j).Value)Then
ActiveSheet.Cells(i,j).Interior.ColorIndex=15
EndIf
Next
Next
EndSub