文件里面是有代码的，但是运行很慢，请问要怎么修改能运行快点吗？

sulli112

文件里面，有左右两边数据，文件里面的代码是，当数据一致时清空两边对应数据，一一对应，因为可能会出现重复单号，条件，一对多情况，这种情况只需要清理一对一的，没有对应的就保留。如果单号一致，就将左边数据复制到右边对应单号位置，但是现在总务上百万，几百条，运行起来很慢，请问要怎么修改能运行快点呢，最好能将找不到的单号，或者是单号一致数据不一致的提取到另一个表格，更方便查看，谢谢

1. Public Sub dsm()
   
2. '找出相同数据并删除
   
3. Dim m As Integer, n As Integer, r1 As Integer, r2 As Integer
   
4. r1 = Range("b65536").End(xlUp).Row
   
5. r2 = Range("i65536").End(xlUp).Row
   
6. For n = 2 To r1
   
7. For m = 2 To r2
   
8. If Range("b" & n) = Range("i" & m) Then
   
9. If CDate(Range("a" & n)) = Range("h" & m) And Range("c" & n) = Range("j" & m) Then
   
10. Range("a" & n & ":c" & n).ClearContents
    
11. Range("h" & m & ":j" & m).ClearContents
    
12. Else
    
13. Range("K" & m).Resize(1, 3) = Range("b" & n).Resize(1, 3).Value
    
14. End If
    
15. Exit For
    
16. End If
    
17. Next
    
18. Next
    
19. End Sub

复制代码

山菊花

供参考。

sulli112

山菊花 发表于 2023-12-14 13:51
供参考。

非常感谢您的，帮助，谢谢

sulli112

山菊花 发表于 2023-12-14 13:51
供参考。

不好意思过了这么久，再来请教一点事情，就是当左边前面三列数据等于右边前面三列数据数据一致时，对应的红色框框那两列D列，K列的数据，也一并清楚，要怎么修改呢

1. Public Sub dsm()
   
2.     '找出相同数据并删除
   
3.     Dim m As Integer, n As Integer, r1 As Integer, r2 As Integer
   
4.     Dim Arr(), Brr(), Crr()
   
5.     Dim ds As Object
   
6.     Set ds = CreateObject("Scripting.Dictionary")
   
7.     r1 = Range("b65536").End(xlUp).Row
   
8.     r2 = Range("i65536").End(xlUp).Row
   
9.     Arr = Range("a3:c" & r1).Value
   
10.     Brr = Range("h3:j" & r2).Value
    
11.     For n = 1 To r1 - 2
    
12.         ds(Arr(n, 2)) = n
    
13.     Next
    
14.     ReDim Crr(1 To r2 - 2, 1 To 3)
    
15.     For m = 1 To r2 - 2
    
16.         If ds.exists(Brr(m, 2)) Then
    
17.             n = ds(Brr(m, 2))
    
18.             For i = 1 To 3
    
19.                 If Arr(n, 1) = Brr(m, 1) And Arr(n, 3) = Brr(m, 3) Then
    
20.                     Arr(n, i) = "": Brr(m, i) = ""
    
21.                 Else
    
22.                     Crr(m, i) = Arr(n, i)
    
23.                 End If
    
24.             Next
    
25.         End If
    
26.     Next
    
27.     Application.EnableEvents = False
    
28.     Application.ScreenUpdating = False
    
29.     Range("a3:c" & r1).Value = Arr
    
30.     Range("h3:j" & r2).Value = Brr
    
31.     Range("k3:m" & r2).Value = Crr
    
32.     Application.EnableEvents = True
    
33.     Application.ScreenUpdating = True
    
34. End Sub
    
35. 
    
36. Public Sub dsm_2()
    
37.     '找出相同数据并删除,将找不到的单号，或者是单号一致数据不一致的提取到另一个表格
    
38.     Dim m As Integer, n As Integer, r1 As Integer, r2 As Integer
    
39.     Dim Arr(), Brr(), Crr(), Drr(), r%, ra%
    
40.     Dim ds As Object
    
41.     Set ds = CreateObject("Scripting.Dictionary")
    
42.     r1 = Range("b65536").End(xlUp).Row
    
43.     r2 = Range("i65536").End(xlUp).Row
    
44.     Arr = Range("a3:c" & r1).Value
    
45.     Brr = Range("h3:j" & r2).Value
    
46.     For n = 1 To r1 - 2
    
47.         ds(Arr(n, 2)) = n
    
48.     Next
    
49.     ReDim Crr(1 To r2 - 2, 1 To 7), Drr(1 To r1 - 2, 1 To 3)
    
50.     For m = 1 To r2 - 2
    
51.         If ds.exists(Brr(m, 2)) Then
    
52.             n = ds(Brr(m, 2))
    
53.             If Arr(n, 1) = Brr(m, 1) And Arr(n, 3) = Brr(m, 3) Then
    
54.                 Arr(n, 1) = "": Arr(n, 3) = ""
    
55.             Else
    
56.                 r = r + 1
    
57.                 If Arr(n, 1) <> "" Then ra = ra + 1
    
58.                 For i = 1 To 3
    
59.                     Crr(r, i) = Brr(m, i)
    
60.                     If Arr(n, 1) <> "" Then
    
61.                         Crr(r, i + 4) = Arr(n, i)
    
62.                         Drr(ra, i) = Arr(n, i)
    
63.                     End If
    
64.                 Next
    
65.             End If
    
66.         Else
    
67.             r = r + 1
    
68.             For i = 1 To 3
    
69.                 Crr(r, i) = Brr(m, i)
    
70.             Next
    
71.         End If
    
72.     Next
    
73.     For n = 1 To r1 - 2
    
74.         If Arr(n, 1) <> "" Then
    
75.             ra = ra + 1
    
76.             For i = 1 To 3
    
77.                 Drr(ra, i) = Arr(n, i)
    
78.             Next
    
79.         End If
    
80.     Next
    
81.     Application.EnableEvents = False
    
82.     Application.ScreenUpdating = False
    
83.     Range("l2:n2").Value = Range("a2:c2").Value
    
84.     Range("a3:c" & r1).Value = Drr
    
85.     Range("h3:n" & r2).Value = Crr
    
86.     Range("l2:n" & r + 2).Borders.LineStyle = 1
    
87.     Application.EnableEvents = True
    
88.     Application.ScreenUpdating = True
    
89. End Sub
    
90. 
    
91. 
    

复制代码

sulli112

山菊花 发表于 2023-12-14 13:51
供参考。

可以辛苦您解答一下我四楼的问题吗，非常感谢

山菊花

Public Sub dsm()
    '找出相同数据并删除
    Dim m As Integer, n As Integer, r1 As Integer, r2 As Integer
    Dim Arr(), Brr(), Crr()
    Dim ds As Object
    Set ds = CreateObject("Scripting.Dictionary")
    r1 = Range("b65536").End(xlUp).Row
    r2 = Range("i65536").End(xlUp).Row
    Arr = Range("a3:d" & r1).Value
    Brr = Range("h3:k" & r2).Value
    For n = 1 To r1 - 2
        ds(Arr(n, 2)) = n
    Next
    ReDim Crr(1 To r2 - 2, 1 To 3)
    For m = 1 To r2 - 2
        If ds.exists(Brr(m, 2)) Then
            n = ds(Brr(m, 2))
            For i = 1 To 4
                If Arr(n, 1) = Brr(m, 1) And Arr(n, 3) = Brr(m, 3) Then
                    Arr(n, i) = "": Brr(m, i) = ""
'                Else
'                    Crr(m, i) = Arr(n, i)
                End If
            Next
        End If
    Next
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Range("a3:d" & r1).Value = Arr
    Range("h3:k" & r2).Value = Brr
'    Range("k3:m" & r2).Value = Crr
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

sulli112

山菊花 发表于 2024-1-8 09:02
Public Sub dsm()
    '找出相同数据并删除
    Dim m As Integer, n As Integer, r1 As Integer, r2 As  ...

首先很感谢您在抽出时间回复我的问题，代码之前运行没有什么问题，不知道为什么这次的数据运行会出现图片（1）第一个问题：原左边数据第一条单号只有一条，但是代码运行之后会变成左边出现这个单号数据两次，请问是什么原因呢？（2）第二个问题，我刚刚复制了您回复的新代码运行，发现是D列数据全部清楚，但是我的意思是如果代码运行之后，B列的单号有数据，那么对应的B列备注保留，一起复制到右边财付通备注，谢谢

山菊花

点击按钮1，得到下面结果：



不保留其中D列内容吗？（K列未见）

sulli112

山菊花 发表于 2024-1-8 14:48
点击按钮1，得到下面结果：

如果财付通跟平台数据，左右两边单号，金额，日期存在一直时候，对应D列数据清空，如果不存在保留，K列是没有数据的，我没有把数据附上，D列数据不需要跟K列数据匹配，因为双方都是备注，肯定不相等的

山菊花

脑补不了数据，你测试一下，看改得是否正确。