VBA 字典 关联定位

Sub Dic_关联()
    Dim Dic As Object
    Dim aData, aRes
    Dim intX&, x&, y&, iRow&, iCol&
    Dim strID$
    aData = Range("B2").CurrentRegion '数据来源
    ReDim aRes(1 To UBound(aData), 1 To UBound(aData, 2)) '定义结果数组大小
    Set Dic = CreateObject("Scripting.Dictionary") '后期绑定字典
    iRow = 1 '数组行位置初始化
    For intX = 2 To UBound(aData) '遍历循环数据源
        strID = aData(intX, 1) & "," & aData(intX, 2) '连接字符串做为关键字 既 地区&","&产品
        If Not Dic.exists(strID) Then '判断关键字是否存在字典中
            iRow = iRow + 1 '结果数组行位置累加
            Dic(strID) = iRow '连接字符串作为关键字Key 数组行位置作为条目Item 写入字典
            Dic(iRow) = 3 '数组行位置作为关键字,条目为3,存入结果数组初始列为第3个位置
            aRes(iRow, 1) = aData(intX, 1) '符合条件的元素写入结果数组
            aRes(iRow, 2) = aData(intX, 2)
            aRes(iRow, 3) = aData(intX, 3)
            Dic(strID & "," & aData(intX, 3)) = "" '为避免出现重复,再次连接字符串 既地区&","&产品&","&业务员
        Else
            If Not Dic.exists(strID & "," & aData(intX, 3)) Then '判断地区&","&产品&","&业务员是否存在字典中
                x = Dic(strID) '取出结果数组行位置 地区&","&产品
                y = Dic(x) + 1 '取出结果数组列位置 并且+1
                If y > UBound(aRes, 2) Then ReDim Preserve aRes(1 To UBound(aRes), 1 To y)
                '判断列位置是否大于结果数据列维度,符合条件使用ReDim Preserve调整结果数组的大小
                aRes(x, y) = aData(intX, 3) '写入业务员
                Dic(x) = y '重新写入字典
                Dic(strID & "," & aData(intX, 3)) = ""
            End If
        End If
    Next
    aRes(1, 1) = "地区": aRes(1, 2) = "产品"
    For y = 3 To UBound(aRes, 2) '循环结果数组第一行
        aRes(1, y) = "业务员" & y - 2 '写入标题
    Next
    Range("F2").Resize(iRow, UBound(aRes, 2)) = aRes '输出内容
    Set Dic = Nothing '释放
End Sub