The VBA code that merges the score table in the Excel workbook is perfect for educating the first-line friends

It is also necessary to merge the worksheets together to form a summary table. At this time more trouble is also more prone to error, because each table of the number is not necessarily consistent, aligned. Because there may be a lack of test, someone is wrong, and so on. Special offer the following code, used to merge student scores or other similar tables can be. This code is characterized in that it does not need to use SQL or access and other big-head software, only need Excel can be executed, very convenient, not slow. Reprint do not clear ads.
Is there a suitable LAN management software? Are your webmaster tools flexible enough to be efficient? Look at this network management software.
' =============================================
' Number of tables not counted when merging summary tables
' Because the General consolidated table is placed on the last sheet, you want to exclude this table.
Const Excludesheetcount = 1
' main function, because ADO is used, you must make the following reference to run this code.
' Tools > references, referring to ADO (Microsoft ActiveX Data Objects 2.X Library)
' Link all sheet to a general 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 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
' Get all test numbers
' EXCEL will automatically remove duplicate data
' SQL = ' (select ID from [Language $]) union (select ID from [English $]) union (select ID from [physical $]) 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 ';d ata 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 does not support UPDATE
' SQL = ' Update [merge $] Set language = ' 1 ' "
' Equivalent to INNER join
' SQL = ' Select Tt.id,ta.score as language, Tb.score as English from [merge $] as TT, [language $] as TA, [English $] as TB "
' sql = SQL & ' WHERE (tt.id = ta.id) and (tt.id = tb.id) "
' Left join all tables
' Pass the tested statement
' SQL = ' Select Tt.id,ta.score as language, Tb.score as English from ([merge $] as TT LEFT JOIN [language $] as TA on tt.id = ta.id) "
' sql = SQL & ' LEFT JOIN [English $] 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
' Clear table
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
' Insert a row in the first row of the table, then merge the cells, plus the caption
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 = "description" & Chr & Chr & _
"The general table for the calculation and generation, the objective results of several single subjects combined together to avoid manual processing due to the misalignment of the test number caused dislocation." "& Chr & Chr (Ten) & _
"Note: If the same test number is present in a single academic score table, the score of the section in the general table is inaccurate. "& Chr & Chr (Ten) & _
"Fill the wrong test number, usually appear at the top or bottom of the table"
Ws. Cells (1, 1) = S1
Activesheet.rows (1). RowHeight = 80
' Freeze panes
Activesheet.rows (3). Select
Activewindow.freezepanes = True
Activewindow.smallscroll down:=0
End Sub
' Set table border
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
' Mark a cell with no score to easily find the student with no score on the answer card
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

