VBA 字典 多表内连接合并查询技巧(学会了我能继续摸鱼)

Sub Dic_JoinData()
    Dim Dic As Object
    Dim aData, aRes, arr, ar
    Dim intx&, intY&, x&, y&, iRow&, iCol&, strInfo$
    On Error Resume Next '出错继续运行
    Application.DisplayAlerts = False '屏蔽弹窗及闪屏
    Application.ScreenUpdating = False
    Set Dic = CreateObject("Scripting.Dictionary")
    aData = Worksheets("Sheet1").Range("A1").CurrentRegion '获取Sheet1工作表数据
    arr = Worksheets("Sheet2").Range("A1").CurrentRegion '获取Sheet2工作表数据
    ReDim aRes(1 To UBound(aData) + UBound(arr), 1 To 1) '定义结果数组大小,结果数组初始列为1
    iRow = 1 '初始化计数器
    For Each ar In Array(aData, arr) '遍历循环两个数据源
        For intY = 1 To UBound(ar, 2) '遍历循环数据源源列
            If Not Dic.exists(ar(1, intY)) Then '判断字典中是否包含标题关键字
                iCol = iCol + 1 '结果数组列累加
                Dic(ar(1, intY)) = iCol '标题为Key对应的Item为结果数组列位置
                If iCol > UBound(aRes, 2) Then ReDim Preserve aRes(1 To UBound(aRes), 1 To iCol) '重新调整结果数组大小
                aRes(1, iCol) = ar(1, intY) '结果数组写入标题
            End If
            For intx = 2 To UBound(ar) '遍历循环数据源行
                strInfo = ar(intx, 1) & ar(intx, 2) & ar(intx, 3) '连接新的字符串作为关键字
                If Not Dic.exists(strInfo) Then '判断关键字是否存在字典中
                    iRow = iRow + 1 '累加结果数组行位置
                    Dic(strInfo) = iRow '新的字符串为Key对应的Item为结果数组行位置
                End If
                x = Dic(strInfo): y = Dic(ar(1, intY)) '从字典中提取对应的Item 既结果数组的行与列
                aRes(x, y) = ar(intx, intY) '写入数据源元素
            Next
        Next
    Next
    Worksheets("汇总").Delete '删除汇总工作表
    With Sheets.Add(after:=Sheets(Sheets.Count)) '新建工作表,并且命名为汇总
        .Name = "汇总"
    End With
    With Worksheets("汇总")
        .Range("a1").Resize(iRow, iCol) = aRes '输出内容
        .UsedRange.Borders.ColorIndex = 23 '添加边框
    End With
    Set Dic = Nothing '释放字典内存
    Application.DisplayAlerts = True '恢复系统设置
    Application.ScreenUpdating = True
End Sub

Sub SQL_JoinData()
    Dim Conn As Object, Rec As Object
    Dim aField, intx&, Sht As Worksheet
    Dim strSQL$, strSource$, strSource1$
    On Error Resume Next
    Application.DisplayAlerts = False '屏蔽弹窗及闪屏
    Application.ScreenUpdating = False
    Set Conn = CreateObject("Adodb.Connection")
    If Application.Version < 12 Then '判断Excel的版本号,以使用不同的连接字符串
        Conn.Open "Provider=Microsoft.ACE.OLEDB.4.0;Extended Properties='Excel 8.0;HDR=yes;IMEX=0';Data Source=" & ThisWorkbook.FullName
    Else
        Conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties='Excel 12.0;HDR=yes;IMEX=0';Data Source=" & ThisWorkbook.FullName
    End If
    strSource = "[Sheet1$]" 'Sheet1数据源
    strSource1 = "[Sheet2$]" 'Sheet2数据源


    strSQL = "Select a.*,政治,历史,化学,生物 From " & strSource & "a," & strSource1 & "b Where a.年级=b.年级 and a.班级=b.班级 and a.姓名=b.姓名"


    Set Rec = Conn.Execute(strSQL)
    ReDim aField(1 To Rec.Fields.Count) 'Fields包含了所有字段的,Fields.Count 得到字段的数量
    For intx = 0 To Rec.Fields.Count - 1 'Fields.Count的下标为0,因此总数-1,字段数组从1开始,所以每次都需要+1
        aField(intx + 1) = Rec.Fields(intx).Name
    Next


    Worksheets("汇总").Delete '删除汇总工作表
    With Sheets.Add(after:=Sheets(Sheets.Count)) '新建工作表,并且命名为汇总
        .Name = "汇总"
    End With
    With Worksheets("汇总")
        .Range("A1").Resize(, UBound(aField)) = aField '写入字段
        .Range("A2").CopyFromRecordset Rec '使用单元格CopyFromRecordset方法将Rec记录写入到指定单元格
        .UsedRange.Borders.ColorIndex = 23 '添加边框
    End With


    Conn.Close '关闭连接
    Set Conn = Nothing '释放
    Set Rec = Nothing '释放
    Application.DisplayAlerts = True '恢复系统设置
    Application.ScreenUpdating = True
End Sub

strSQL = "Select a.*,政治,历史,化学,生物 From " & strSource & "a," & strSource1 & "b Where a.年级=b.年级 and a.班级=b.班级 and a.姓名=b.姓名"

strSQL = "Select a.*,政治,历史,化学,生物 From " & strSource & "a," & strSource1 & "b Where a.年级&a.班级&a.姓名=b.年级&b.班级&b.姓名"