這時候還需要把各個工作表合并到一起來形成一個匯總表。這時候比較麻煩也比較容易出錯，因為各個表的學(xué)號不一定都是一致的、對齊的。因為可能會有人缺考，有人會考號涂錯等等。特奉獻以下代碼，用于合并學(xué)生成績表或者其它類似的表都可以。本代碼特點在于不需要使用SQL或者Access等大頭軟件，只需要Excel就可以執(zhí)行，非常方便，速度也不慢。轉(zhuǎn)載請勿清除廣告。
沒有合適的局域網(wǎng)管理軟件嗎？你的網(wǎng)管工具夠靈活夠高效嗎？看看這個network management software。
' =============================================
' 合并總表時，不參加計算的表格數(shù)目
' 因為一般合并的總表放在最后一個工作表，要排除掉這個表。
Const ExcludeSheetCount = 1
' 主函數(shù)，因為用到了ADO，必須作如下引用才能運行本代碼。
' 工具>引用， 引用ADO(Microsoft ActiveX Data Objects 2.X Library)
' 鏈接所有sheet到一個總表
' 要合并的表的第一行必須是字段名稱，不能是合并單元格
Sub SQL_ADO_EXCEL_JOIN_ALL()
Dim cnn As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim i, k, shCount As Integer
Dim SQL, SQL2 As String, cnnStr As String
Dim s1, s2, s3, tmp As String
Dim ws As Worksheet
Const IDIdx = 1
Const ScoreIdx = 3
shCount = ActiveWorkbook.Sheets.Count
' 獲取所有考號
' EXCEL 會自動去除重復(fù)數(shù)據(jù)
' SQL = "(select ID from [語文$]) union (select ID from [英語$]) union (select ID from [物理$]) order by ID"
SQL = ""
For i = 1 To shCount - ExcludeSheetCount
s1 = "(SELECT ID FROM [" & Sheets(i).Name & "$])"
If i = 1 Then
SQL = s1
Else
SQL = SQL & " UNION " & s1
End If
Next
'MsgBox SQL
Set ws = ActiveWorkbook.Sheets(shCount)
cnnStr = "provider = microsoft.jet.oledb.4.0;Extended Properties='Excel 8.0;HDR=yes;IMEX=1';data source=" & ThisWorkbook.FullName
cnn.CursorLocation = adUseClient
cnn.ConnectionString = cnnStr
cnn.Open
rs.Open SQL, cnn, adOpenKeyset, adLockOptimistic
ws.Activate
ws.Cells.Clear
For i = 1 To rs.Fields.Count
ws.Cells(1, i) = rs.Fields(i - 1).Name
Next
ws.Range("A2").CopyFromRecordset rs
For i = 1 To shCount - ExcludeSheetCount
Sheets(shCount).Cells(1, i + 1) = Sheets(i).Name
Next
'EXCEL 不支持 UPDATE
'SQL = "update [合并$] set 語文 = '1'"
' 相當(dāng)于內(nèi)聯(lián)接
'SQL = "select tt.ID,ta.score as 語文,tb.score as 英語 from [合并$] AS tt, [語文$] as ta, [英語$] as tb "
'SQL = SQL & "where (tt.ID = ta.ID) and (tt.ID = tb.ID)"
' 左聯(lián)接所有表格
' 通過測試的語句
'SQL = "select tt.ID,ta.score AS 語文,tb.score as 英語 from ([合并$] AS tt left join [語文$] as ta on tt.ID = ta.ID) "
'SQL = SQL & "left join [英語$] as tb on tt.ID = tb.ID"
SQL2 = "([" & Sheets(shCount).Name & "$] AS tt LEFT JOIN [" & Sheets(1).Name & "$] AS t1 ON tt.id=t1.id) "
SQL = "SELECT tt.ID,"
For i = 1 To shCount - ExcludeSheetCount
tmp = "t" & i
SQL = SQL & tmp & ".score AS " & Sheets(i).Name
If i < shCount - ExcludeSheetCount Then SQL = SQL & ", "
If i > 1 Then
SQL2 = "(" & SQL2 & " LEFT JOIN [" & Sheets(i).Name & "$] AS " & tmp & " ON tt.id=" & tmp & ".id)"
End If
Next
s1 = SQL & " FROM " & SQL2 & " ORDER BY tt.ID"
MsgBox s1
rs.Close
rs.Open s1, cnn, adOpenKeyset, adLockOptimistic
' 清除表格
ws.Activate
Cells.Select
Selection.Delete Shift:=xlUp
For i = 1 To rs.Fields.Count
ws.Cells(1, i) = rs.Fields(i - 1).Name
Next
ws.Range("A2").CopyFromRecordset rs
rs.Close
cnn.Close
Set rs = Nothing
Set cnn = Nothing
Call AddHeader
Call FindBlankCells
Call TableBorderSet
ws.Columns(1).AutoFit
ws.Cells(2, 1).Select
MsgBox "Finished."
End Sub
' 在表格第一行插入行，然后合并單元格，加上說明文字
Sub AddHeader()
Dim ws As Worksheet
Dim s1, s2 As String
shCount = ActiveWorkbook.Sheets.Count
Set ws = 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) & _
"本總表為計算生成，把幾個單科的客觀題成績合并在一起，避免手工處理時因考號不對齊而導(dǎo)致錯位。" & Chr(13) & Chr(10) & _
"注意：如果某單科成績表中存在相同考號，則總表中該考號的該科成績是不準(zhǔn)確的。" & Chr(13) & Chr(10) & _
"填涂錯誤的考號，一般出現(xiàn)在表里頂端或底端"
ws.Cells(1, 1) = s1
ActiveSheet.Rows(1).RowHeight = 80
' 凍結(jié)窗格
ActiveSheet.Rows(3).Select
ActiveWindow.FreezePanes = True
ActiveWindow.SmallScroll Down:=0
End Sub
' 設(shè)置表格邊框
Sub TableBorderSet()
ActiveSheet.UsedRange.Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
' 標(biāo)記無分?jǐn)?shù)的單元格，方便找出答題卡沒有分?jǐn)?shù)的學(xué)生
Sub FindBlankCells()
Dim i, j, row, col As Integer
'ActiveSheet.Cells(2, 1).Interior.ColorIndex = 15
row = ActiveSheet.UsedRange.Rows.Count
col = ActiveSheet.UsedRange.Columns.Count
For i = 2 To row
For j = 2 To col
If IsEmpty(ActiveSheet.Cells(i, j).Value) Then
ActiveSheet.Cells(i, j).Interior.ColorIndex = 15
End If
Next
Next
End Sub

最新評論