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

feixiangye · 发表于 2023-10-25 16:59

本帖最后由 feixiangye 于 2023-10-25 17:04 编辑

yynrzwh 发表于 2023-10-22 10:27

老师您好，不好意思，您帮忙写的这段代码，有一种情况我忘了考虑，您的代码我研究了两天，自己改来改去还是改不对，可以帮忙再看下代码吗，谢谢！

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

yynrzwh · 发表于 2023-10-25 17:27

feixiangye 发表于 2023-10-25 16:59
老师您好，不好意思，您帮忙写的这段代码，有一种情况我忘了考虑，您的代码我研究了两天，自己改来改去还 ...

A,E相同的优先排一起吗？
这样有空再研究下。

feixiangye · 发表于 2023-10-25 21:43

yynrzwh 发表于 2023-10-25 17:27
A,E相同的优先排一起吗？
这样有空再研究下。

是的，谢谢！

yynrzwh · 发表于 2023-10-25 23:15

你测试下

数据比对3.rar (18.33 KB, 下载次数: 11)

feixiangye · 发表于 2023-10-26 08:42

yynrzwh 发表于 2023-10-25 23:15
你测试下

结果是想要的最终结果，非常完美，十分感谢，我再好好研究研究您的代码逻辑，看能不能掌握，再次感谢！

笨鸟飞不高 · 发表于 2023-10-26 10:09

本帖最后由笨鸟飞不高于 2023-10-26 10:57 编辑

数据比对.zip (24.12 KB, 下载次数: 1)

换个思路，练习一下！

笨鸟飞不高 · 发表于 2023-10-26 10:33

Sub AwTest2()
Dim i&, j%, k%, m%, n%, l%, r&, Ra&, Rb&, kSr, Arr, Brr, Crr, Iar, Tar(), d As Object
Set d = 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")
      d(Arr(i, 1))(Arr(i, 2)) = i & "|"
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")
         d(Brr(i, 1))(Brr(i, 2)) = "|" & i
      Else
         If Not d(Brr(i, 1)).Exists(Brr(i, 2)) Then
            d(Brr(i, 1))(Brr(i, 2)) = "|" & i
         Else
            d(Brr(i, 1))(Brr(i, 2)) = d(Brr(i, 1))(Brr(i, 2)) & i
         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
      For k = 0 To UBound(Iar)
         m = InStr(Iar(k), "|")
         Ra = 0: Rb = 0
'          l = 0  l 位置修改一下
         If m = Len(Iar(k)) Then
            Ra = Split(Iar(k), "|")(0)
         ElseIf m = 1 Then
            Rb = Split(Iar(k), "|")(1)
         Else
            Ra = Split(Iar(k), "|")(0)
            Rb = Split(Iar(k), "|")(1)
         End If
         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 Tar(1 To n): Tar(n) = r '记录右边可排列数据的空白位置行号
            End If
         Else
            If n Then
                  l = l + 1
                  For j = 1 To UBound(Brr, 2)
                     Crr(Tar(l), j + 4) = Brr(Rb, j)
                  Next
                  n = n - 1
            Else
                  r = r + 1
                  For j = 1 To UBound(Brr, 2)
                     Crr(r, 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 10:36

yynrzwh 发表于 2023-10-25 23:15
你测试下

老师您好，不好意思，刚测试发现这种情况的时候会不符，谢谢！

feixiangye · 发表于 2023-10-26 10:43

笨鸟飞不高发表于 2023-10-26 10:09
换个思路，练习一下！

漏说了一种情况，A,E相同的,BF不同的优先排一起，BF列相同但AE不同的也需要排列一起，谢谢！

笨鸟飞不高 · 发表于 2023-10-26 11:41

feixiangye 发表于 2023-10-26 10:43
漏说了一种情况，A,E相同的,BF不同的优先排一起，BF列相同但AE不同的也需要排列一起，谢谢！

数据比对3.zip (23.57 KB, 下载次数: 3)

凑一个！

		自动登录	找回密码
密码			免费注册

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

评分

评分

评分