Excel ブック内の成績表を結合するための VBA コード。教育の最前線にいる友人に非常に適しています。

このとき、さまざまなワークシートを結合して要約表を作成する必要もあります。各表の生徒数が必ずしも一貫して揃っているわけではないため、これはさらに面倒で間違いが発生しやすくなります。試験を見逃してしまう人もいるかもしれないので、受験番号を間違えて書いてしまう人もいるかもしれません。次のコードは専用であり、生徒のスコア テーブルまたは他の同様のテーブルを結合するために使用できます。このコードの特徴は、SQL や Access などの大きなソフトウェアを使用する必要がなく、実行に必要なのは Excel だけであり、非常に便利です。転載する際は広告を消さないで下さい。
適切な LAN 管理ソフトウェアをお持ちですか?ネットワーク管理ツールは十分に柔軟で効率的ですか?このネットワーク管理ソフトウェアを見てください。
' =========================================== =
' マスターテーブルを結合する際、計算に含まれないテーブルの数
' 結合されたマスターテーブルは通常最後のワークシートに配置されるため、このテーブルは除外する必要があります。
Const ExcludeSheetCount = 1
' main 関数は ADO を使用しているため、このコードを実行するには次のように参照する必要があります。
' ツール>リファレンス、リファレンス ADO (Microsoft ActiveX Data Objects 2.X Library)
' すべてのシートを合計テーブルにリンクします
' マージされるテーブルの最初の行はフィールド名である必要があります。セルを結合しません
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 は重複データを自動的に削除します
' SQL = "([Language$] から ID を選択) Union ([English$] から ID を選択) Union ([Physical$] から ID を選択) ] ]) 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;拡張プロパティ='Excel 8.0;HDR=yes;IMEX=1';データ ソース= & ThisWorkbook.FullName
cnn .CursorLocation = adUseClient
cnn.ConnectionString = cnnStr
cnn.Open
rs.Open SQL、cnn、adOpenKeyset、adLockOptimistic
ws.Activate
ws.Cells.Clear
For i = 1 rs.Fields.Count へ
ws.Cells(1, i) = rs.Fields(i - 1).Name
次
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 [Merge$] set Chinese = '1'"
' 内部結合と同等
'SQL = "select tt.ID,ta.score as Chinese,tb.score as English from [Merge$] ] AS tt、[中国語$] as ta、[English$] as tb "
'SQL = SQL & "where (tt.ID = ta.ID) and (tt.ID = tb.ID)"
' すべてのテーブルを左結合
' テストに合格したステートメント
'SQL = "select tt.ID,ta.score AS Chinese,tb.score as English from ([Merge$] AS tt left join [中国語] $] 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 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 rs.Fields.Count へ
ws.Cells(1, i) = rs.Fields(i - 1).Name
次
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) & _
"この集計表手動処理​​中のテスト番号のずれによるずれを避けるために、複数の単一被験者の客観的なテストスコアが計算によって生成されます。 " & 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.SmallScroll Down:=0
End Sub
' 表の境界線を設定します
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
次で終了
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
次で終了
With Selection.Borders (xlInsideVertical)
.LineStyle = xlContinuous
.Weight = xlThin
.ColorIndex = xlAutomatic
End With
With Selection.Borders(xlInsidehorizo​​ntal)
.LineStyle = xlContinuous Weight = xlThin>。
.ColorIndex = xlAutomatic
End With
End Sub
' 得点のないセルをマークして、解答用紙に得点のない生徒を簡単に見つけます
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
i = 2 の場合、行
の場合、j = 2 の場合、列
If IsEmpty(ActiveSheet.Cells(i, j).Value) の場合、
ActiveSheet.Cells(i, j)。
End If
Next
Next
End Sub