This time also need to merge the various worksheets together to form a summary table. This time is more troublesome and more prone to error, because the number of students in each table may not always be consistent and aligned. Because there may be some people missing the exam, some people will be wrongly painted exam number and so on. Special dedication to the following code for the merger of student achievement tables or other similar tables can be. This code is characterized by not needing to use SQL or Access and other big head of software, only Excel can be executed, very convenient, the speed is not slow. Please do not remove the advertisement.
Don't have the right LAN management software? Is your network management tool flexible enough and efficient enough? Check out this network management software.
' =============================================
' Number of tables excluded from calculations when combining summary tables
' Because the general merged summary table is placed on the last worksheet to be excluded.
Const ExcludeSheetCount = 1
' The main function, because it uses ADO, must be referenced as follows in order to run this code.
' Tools > references, references ADO (Microsoft ActiveX Data Objects Library)
' Link all sheets to a summary table
' The first row of the table to be merged must be a field name, not a merged cell
Sub SQL_ADO_EXCEL_JOIN_ALL()
Dim cnn As New
Dim rs As New
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 =
' Get All Exam Numbers
' EXCEL automatically removes duplicate data
' SQL = "(select ID from [multilingualism$]) union (select ID from [English (language)$]) union (select ID from [physiotherapy$]) 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 = (shCount)
cnnStr = "provider = .4.0;Extended Properties='Excel 8.0;HDR=yes;IMEX=1';data source=" &
= adUseClient
= cnnStr
SQL, cnn, adOpenKeyset, adLockOptimistic
For i = 1 To
(1, i) = (i - 1).Name
Next
("A2").CopyFromRecordset rs
For i = 1 To shCount - ExcludeSheetCount
Sheets(shCount).Cells(1, i + 1) = Sheets(i).Name
Next
'EXCEL does not support UPDATE
' SQL = "update [merge$] set language = '1'"
' Equivalent to an inline connection
'SQL = "select , as language, as English from [merge$] AS tt, [language$] as ta, [English$] as tb "
'SQL = SQL & "where ( = ) and ( = )"
' Left-link all tables
' Statements that pass the test
'SQL = "select , AS multilingualism, as English (language) from ([incorporation$] AS tt left join [multilingualism$] as ta on = ) "
'SQL = SQL & "left join [English$] as tb on = "
SQL2 = "([" & Sheets(shCount).Name & "$] AS tt LEFT JOIN [" & Sheets(1).Name & "$] AS t1 ON =) "
SQL = "SELECT ,"
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 =" & tmp & ".id)"
End If
Next
s1 = SQL & " FROM " & SQL2 & " ORDER BY "
MsgBox s1
s1, cnn, adOpenKeyset, adLockOptimistic
' Clear Forms
Shift:=xlUp
For i = 1 To
(1, i) = (i - 1).Name
Next
("A2").CopyFromRecordset rs
Set rs = Nothing
Set cnn = Nothing
Call AddHeader
Call FindBlankCells
Call TableBorderSet
(1).AutoFit
(2, 1).Select
MsgBox "Finished."
End Sub
' Insert rows in the first row of the table, then merge cells and add explanatory text
Sub AddHeader()
Dim ws As Worksheet
Dim s1, s2 As String
shCount =
Set ws = Sheets(shCount)
Column =
(1).Insert
s1 = Chr(Asc("A") + Column - 1)
s2 = "A1:" & s1 & "1"
(s2).Merge
(1).RowHeight = 100
s1 = "Description" & Chr(13) & Chr(10) & _
"This summary table is computationally generated by combining the objective scores of several individual subjects to avoid misalignment due to misaligned test numbers during manual processing." & Chr(13) & Chr(10) & _
"Note: If the same test number exists in the results table for a single subject, the results for that subject for that test number in the summary table are inaccurate." & Chr(13) & Chr(10) & _
"An incorrectly filled-in test number, usually found at the top or bottom of the table"
(1, 1) = s1
(1).RowHeight = 80
' Freeze Pane
(3).Select
= True
Down:=0
End Sub
' Setting Form Borders
Sub TableBorderSet()
(xlDiagonalDown).LineStyle = xlNone
(xlDiagonalUp).LineStyle = xlNone
With (xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With (xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With (xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With (xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With (xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With (xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
' Mark cells with no scores to make it easier to identify students with no scores on their answer cards
Sub FindBlankCells()
Dim i, j, row, col As Integer
'(2, 1). = 15
row =
col =
For i = 2 To row
For j = 2 To col
If IsEmpty((i, j).Value) Then
(i, j). = 15
End If
Next
Next
End Sub
Don't have the right LAN management software? Is your network management tool flexible enough and efficient enough? Check out this network management software.
' =============================================
' Number of tables excluded from calculations when combining summary tables
' Because the general merged summary table is placed on the last worksheet to be excluded.
Const ExcludeSheetCount = 1
' The main function, because it uses ADO, must be referenced as follows in order to run this code.
' Tools > references, references ADO (Microsoft ActiveX Data Objects Library)
' Link all sheets to a summary table
' The first row of the table to be merged must be a field name, not a merged cell
Sub SQL_ADO_EXCEL_JOIN_ALL()
Dim cnn As New
Dim rs As New
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 =
' Get All Exam Numbers
' EXCEL automatically removes duplicate data
' SQL = "(select ID from [multilingualism$]) union (select ID from [English (language)$]) union (select ID from [physiotherapy$]) 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 = (shCount)
cnnStr = "provider = .4.0;Extended Properties='Excel 8.0;HDR=yes;IMEX=1';data source=" &
= adUseClient
= cnnStr
SQL, cnn, adOpenKeyset, adLockOptimistic
For i = 1 To
(1, i) = (i - 1).Name
Next
("A2").CopyFromRecordset rs
For i = 1 To shCount - ExcludeSheetCount
Sheets(shCount).Cells(1, i + 1) = Sheets(i).Name
Next
'EXCEL does not support UPDATE
' SQL = "update [merge$] set language = '1'"
' Equivalent to an inline connection
'SQL = "select , as language, as English from [merge$] AS tt, [language$] as ta, [English$] as tb "
'SQL = SQL & "where ( = ) and ( = )"
' Left-link all tables
' Statements that pass the test
'SQL = "select , AS multilingualism, as English (language) from ([incorporation$] AS tt left join [multilingualism$] as ta on = ) "
'SQL = SQL & "left join [English$] as tb on = "
SQL2 = "([" & Sheets(shCount).Name & "$] AS tt LEFT JOIN [" & Sheets(1).Name & "$] AS t1 ON =) "
SQL = "SELECT ,"
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 =" & tmp & ".id)"
End If
Next
s1 = SQL & " FROM " & SQL2 & " ORDER BY "
MsgBox s1
s1, cnn, adOpenKeyset, adLockOptimistic
' Clear Forms
Shift:=xlUp
For i = 1 To
(1, i) = (i - 1).Name
Next
("A2").CopyFromRecordset rs
Set rs = Nothing
Set cnn = Nothing
Call AddHeader
Call FindBlankCells
Call TableBorderSet
(1).AutoFit
(2, 1).Select
MsgBox "Finished."
End Sub
' Insert rows in the first row of the table, then merge cells and add explanatory text
Sub AddHeader()
Dim ws As Worksheet
Dim s1, s2 As String
shCount =
Set ws = Sheets(shCount)
Column =
(1).Insert
s1 = Chr(Asc("A") + Column - 1)
s2 = "A1:" & s1 & "1"
(s2).Merge
(1).RowHeight = 100
s1 = "Description" & Chr(13) & Chr(10) & _
"This summary table is computationally generated by combining the objective scores of several individual subjects to avoid misalignment due to misaligned test numbers during manual processing." & Chr(13) & Chr(10) & _
"Note: If the same test number exists in the results table for a single subject, the results for that subject for that test number in the summary table are inaccurate." & Chr(13) & Chr(10) & _
"An incorrectly filled-in test number, usually found at the top or bottom of the table"
(1, 1) = s1
(1).RowHeight = 80
' Freeze Pane
(3).Select
= True
Down:=0
End Sub
' Setting Form Borders
Sub TableBorderSet()
(xlDiagonalDown).LineStyle = xlNone
(xlDiagonalUp).LineStyle = xlNone
With (xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With (xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With (xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With (xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With (xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With (xlInsideHorizontal)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
End Sub
' Mark cells with no scores to make it easier to identify students with no scores on their answer cards
Sub FindBlankCells()
Dim i, j, row, col As Integer
'(2, 1). = 15
row =
col =
For i = 2 To row
For j = 2 To col
If IsEmpty((i, j).Value) Then
(i, j). = 15
End If
Next
Next
End Sub