想用VBA对两组数据进行比对重新排列，自己写了很久无法完美实现，求助前辈们看看

笨鸟飞不高

Sub AwTest3()
    Dim i&, j%, k%, n%, l%, m&, x&, r&, Ra&, Rb&, kSr
    Dim Arr, Brr, Crr, Iar, Tar, Tbr(), d As Object, dd As Object
    Set d = CreateObject("Scripting.Dictionary")
    Set dd = CreateObject("Scripting.Dictionary")
    Arr = Range("A1").CurrentRegion
    For i = 2 To UBound(Arr)
        If Not d.exists(Arr(i, 1)) Then Set d(Arr(i, 1)) = CreateObject("Scripting.Dictionary")
        ReDim Tar(1 To 2): Tar(1) = i
        d(Arr(i, 1))(Arr(i, 2)) = Tar
    Next
    Brr = Range("E1").CurrentRegion
    For i = 2 To UBound(Brr)
        If Not d.exists(Brr(i, 1)) Then
            Set d(Brr(i, 1)) = CreateObject("Scripting.Dictionary")
            ReDim Tar(1 To 2): Tar(2) = i
            d(Brr(i, 1))(Brr(i, 2)) = Tar
        Else
            If Not d(Brr(i, 1)).exists(Brr(i, 2)) Then
                ReDim Tar(1 To 2): Tar(2) = i
                d(Brr(i, 1))(Brr(i, 2)) = Tar
            Else
                Tar = d(Brr(i, 1))(Brr(i, 2))
                Tar(2) = i
                d(Brr(i, 1))(Brr(i, 2)) = Tar
            End If
        End If
    Next
    ReDim Crr(1 To UBound(Arr) + UBound(Brr), 1 To 7)
    For Each kSr In d
        Iar = d(kSr).Items
        n = 0: l = 0: Erase Tar: Erase Tbr
        For k = 0 To UBound(Iar)
            Tar = Iar(k)
            Ra = Val(Tar(1)): Rb = Val(Tar(2))
            If Ra Then
                r = r + 1
                For j = 1 To UBound(Arr, 2)
                    Crr(r, j) = Arr(Ra, j)
                Next
                If Rb Then
                    For j = 1 To UBound(Brr, 2)
                        Crr(r, j + 4) = Brr(Rb, j)
                    Next
                Else
                    n = n + 1
                    ReDim Preserve Tbr(1 To n): Tbr(n) = r '记录右边可排列数据的空白位置行号
                    dd(Arr(Ra, 2)) = r
                End If
            Else
                If n Then
                    l = l + 1
                    For j = 1 To UBound(Brr, 2)
                        Crr(Tbr(l), j + 4) = Brr(Rb, j)
                    Next
                    n = n - 1
                    If dd.exists(Arr(Tbr(l), 2)) Then dd.Remove (Arr(Tbr(l), 2)) '这句修改一下
                Else
                    m = dd(Brr(Rb, 2))
                    If m Then x = m Else r = r + 1: x = r
                    For j = 1 To UBound(Brr, 2)
                        Crr(x, j + 4) = Brr(Rb, j)
                    Next
                End If
            End If
        Next
    Next
    If r Then Range("Y2").Resize(r, 7) = Crr
End Sub

feixiangye

笨鸟飞不高 发表于 2023-10-26 11:53
Sub AwTest3()
    Dim i&, j%, k%, n%, l%, m&, x&, r&, Ra&, Rb&, kSr
    Dim Arr, Brr, Crr, Iar, Ta ...

老师您好，运行到这一句的时候会报错，烦请帮忙看看，谢谢！

笨鸟飞不高

feixiangye 发表于 2023-10-26 13:27
老师您好，运行到这一句的时候会报错，烦请帮忙看看，谢谢！

看一下31楼的修改

feixiangye

笨鸟飞不高 发表于 2023-10-26 14:20
看一下31楼的修改

谢谢，太完美了

zpy2

一招秒杀 发表于 2023-10-24 21:02
最简单的1行，谁都能看懂，没有疑义，无差错完美解决。

.两列内容不同的：如果A列与E列名称相同的排列一起； ----也会有B列与F列相同但A与E不同的，也需要排列一起，如下案例.


这个 全连接 没法处理特殊情况。。。。

feixiangye

笨鸟飞不高 发表于 2023-10-26 11:53
Sub AwTest3()
    Dim i&, j%, k%, n%, l%, m&, x&, r&, Ra&, Rb&, kSr
    Dim Arr, Brr, Crr, Iar, Ta ...

老师您好，这个案例测试有问题，烦请帮忙看下，谢谢！

笨鸟飞不高

feixiangye 发表于 2023-10-26 16:19
老师您好，这个案例测试有问题，烦请帮忙看下，谢谢！

数据比对3.rar (20.8 KB, 下载次数: 9)

2023-10-26 19:12 上传

点击文件名下载附件

参考！

一招秒杀

zpy2 发表于 2023-10-26 15:56
.两列内容不同的：如果A列与E列名称相同的排列一起； ----也会有B列与F列相同但A与E不同的，也需要排列一 ...

有人需要 90+行代码，我觉得只需要更简短的1行就足够了，有图有真相。

feixiangye

笨鸟飞不高 发表于 2023-10-26 19:13
参考！

大神您好，这个案例代码执行结果不是想要的结果，您的代码我研究了好久，一直无法理解透彻代码逻辑，不知代码该如何修改，还请您有空时帮忙看下这个案例要如何修改代码，谢谢！

feixiangye

笨鸟飞不高 发表于 2023-10-26 19:13
参考！

大神您好，这个案例代码执行结果会缺少一行数据，如果ABC和EFG两组数据调换一下位置，执行代码后结果则是正确的，您的代码我研究了好久，一直无法理解透彻代码逻辑，不知代码该如何修改，烦请您有空时帮忙看下这个案例要如何修改代码，谢谢！