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

chxw68

feixiangye 发表于 2023-10-23 08:58
老师您好，您的写法2是我想要的最终结果，但有一个结果对应顺序不对，其余的结果都对，烦请帮忙看下 ...

相同Part的PN有重复的吗？如果有重复的就更麻烦了。

feixiangye

chxw68 发表于 2023-10-23 09:37
相同Part的PN有重复的吗？如果有重复的就更麻烦了。

相同Part的PN同组里面没有重复的

chxw68

笨办法参与一下。

feixiangye

chxw68 发表于 2023-10-23 10:38
笨办法参与一下。

好的，谢谢，我好好研究一下您的代码

chxw68

feixiangye 发表于 2023-10-23 10:44
好的，谢谢，我好好研究一下您的代码

结果对不对？

feixiangye

chxw68 发表于 2023-10-23 10:58
结果对不对？

结果是对的，谢谢

汉唐

练下手.....

笨鸟飞不高

数据比对.zip (19.6 KB, 下载次数: 10)

2023-10-23 13:40 上传

点击文件名下载附件

凑一个！

feixiangye

shiruiqiang 发表于 2023-10-21 21:54
没事练手，两种稍微有点不一样的排序

老师您好，您帮忙写的代码，最终结果想要标记红色这条记录下移到下面，您的代码我尝试修改了一下，可是结果还是不对，烦请帮忙不吝再指导一下代码该怎么修改，谢谢！

Sub 比对写法2()
    Dim arr, brr, crr(1 To 1000, 1 To 7)
    Dim d, d1
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    arr = [a1].CurrentRegion
    For x = 2 To 13
        If Not d.exists(arr(x, 1)) Then Set d(arr(x, 1)) = CreateObject("scripting.dictionary")
        If Not d(arr(x, 1)).exists(arr(x, 2)) Then Set d(arr(x, 1))(arr(x, 2)) = CreateObject("scripting.dictionary")
        d(arr(x, 1))(arr(x, 2))("a") = arr(x, 3)
    Next
    brr = [e1].CurrentRegion
    For i = 2 To UBound(brr)
        If Not d.exists(brr(i, 1)) Then Set d(brr(i, 1)) = CreateObject("scripting.dictionary")
        If Not d(brr(i, 1)).exists(brr(i, 2)) Then Set d(brr(i, 1))(brr(i, 2)) = CreateObject("scripting.dictionary")
        d(brr(i, 1))(brr(i, 2))("b") = brr(i, 3)
    Next
    For Each aa In d.keys
        For Each bb In d(aa).keys
            For Each cc In d(aa)(bb).keys
                If cc = "a" Then
                    n = n + 1
                    crr(n, 1) = aa
                    crr(n, 2) = bb
                    crr(n, 3) = d(aa)(bb)(cc)
                Else
                    m = m + 1
                    crr(m, 5) = aa
                    crr(m, 6) = bb
                    crr(m, 7) = d(aa)(bb)(cc)
                End If
            Next
        Next
        If m > n Then
            n = m
        Else
            m = n
        End If
    Next
    [i2].Resize(UBound(crr), 7) = crr
End Sub

一招秒杀

最简单的1行，谁都能看懂，没有疑义，无差错完美解决。