把重复的代码搞进类模块，也不知道对不对，反正我是没报错。
表1：一班
姓名 语文 数学 英语 天 136 140 21 地 62 90 98 玄 200 126 10
表2：二班
姓名 语文 数学 英语 子 82 97 65 丑 55 99 46 寅 54 61 60
表3：三班
姓名 语文 数学 英语 甲 110 110 100 乙 110 102 101 丙 107 106 110
类模块：数据库
1 Property Get Excel数据库(Mypath As String) 2 If Application.Version < 12 Then 3 Excel数据库 = "Provider=Microsoft.jet.OLEDB.4.0;Extended Properties=Excel 8.0;Data Source=" & Mypath 4 Else 5 Excel数据库 = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12.0;Data Source=" & Mypath 6 End If 7 End Property 8 9 Sub 查询(MyData As String, sql As String, rng As Range) 10 Dim cnn As Object, rst As Object, i& 11 Set cnn = CreateObject("adodb.connection") 12 cnn.Open MyData 13 Set rst = cnn.Execute(sql) 14 Cells.ClearComments 15 For i = 0 To rst.Fields.Count - 1 16 rng.Offset(-1, i) = rst.Fields(i).Name 17 Next 18 rng.CopyFromRecordset rst 19 cnn.Close 20 Set cnn = Nothing 21 End Sub
调用类模块：
1 Sub 并表查询2() 2 Dim sql As String, Sql1 As String 3 Dim Sht As Worksheet, Sht_name As String 4 Dim i As Long, Mypath As String, rng As Range 5 Mypath = ThisWorkbook.FullName 6 Set rng = ActiveSheet.Range("a2") 7 Dim data As New 数据库 8 Sql1 = "SELECT 姓名,语文,数学,英语," 9 For Each Sht In Worksheets 10 Sht_name = Sht.Name 11 If Sht_name <> ActiveSheet.Name Then 12 sql = sql & Sql1 & "'" & Sht_name & "' AS 班级 FROM [" & Sht_name & "$] UNION ALL " 13 End If 14 Next 15 sql = Left(sql, Len(sql) - 11) 16 17 data.查询 data.Excel数据库(Mypath), sql, rng 18 19 End Sub
查询结果：
姓名 语文 数学 英语 班级 天 136 140 21 一班 地 62 90 98 一班 玄 200 126 10 一班 子 82 97 65 二班 丑 55 99 46 二班 寅 54 61 60 二班 甲 110 110 100 三班 乙 110 102 101 三班 丙 107 106 110 三班