這時(shí)候還需要把各個(gè)工作表合并到一起來形成一個(gè)匯總表。這時(shí)候比較麻煩也比較容易出錯(cuò)，因?yàn)楦鱾€(gè)表的學(xué)號(hào)不一定都是一致的、對(duì)齊的。因?yàn)榭赡軙?huì)有人缺考，有人會(huì)考號(hào)涂錯(cuò)等等。特奉獻(xiàn)以下代碼，用于合并學(xué)生成績(jī)表或者其它類似的表都可以。本代碼特點(diǎn)在于不需要使用SQL或者Access等大頭軟件，只需要Excel就可以執(zhí)行，非常方便，速度也不慢。轉(zhuǎn)載請(qǐng)勿清除廣告。
沒有合適的局域網(wǎng)管理軟件嗎？你的網(wǎng)管工具夠靈活夠高效嗎？看看這個(gè)network management software。
' =============================================
' 合并總表時(shí)，不參加計(jì)算的表格數(shù)目
' 因?yàn)橐话愫喜⒌目偙矸旁谧詈笠粋€(gè)工作表，要排除掉這個(gè)表。
Const ExcludeSheetCount = 1
' 主函數(shù)，因?yàn)橛玫搅薃DO，必須作如下引用才能運(yùn)行本代碼。
' 工具>引用， 引用ADO(Microsoft ActiveX Data Objects 2.X Library)
' 鏈接所有sheet到一個(gè)總表
' 要合并的表的第一行必須是字段名稱，不能是合并單元格
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
' 獲取所有考號(hào)
' EXCEL 會(huì)自動(dòng)去除重復(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)接所有表格
' 通過測(cè)試的語句
'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) & _
"本總表為計(jì)算生成，把幾個(gè)單科的客觀題成績(jī)合并在一起，避免手工處理時(shí)因考號(hào)不對(duì)齊而導(dǎo)致錯(cuò)位。" & Chr(13) & Chr(10) & _
"注意：如果某單科成績(jī)表中存在相同考號(hào)，則總表中該考號(hào)的該科成績(jī)是不準(zhǔn)確的。" & Chr(13) & Chr(10) & _
"填涂錯(cuò)誤的考號(hào)，一般出現(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

最新評(píng)論