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

sulli112

山菊花 发表于 2024-1-8 20:09
脑补不了数据，你测试一下，看改得是否正确。

（一）第一个代码是我想要的效果，但是为什么运行起来会卡顿，没有您的第一个版本顺滑，是什么情况呢
（二）第二个代码显示下标越界，是什么情况呢，M列复制单号的时候会自动转为数值，能有办法默认是文本格式吗，因为单号较长，有时候是超15为数字，非常感谢

山菊花

Public Sub dsm_2()
    '找出相同数据并删除,将找不到的单号，或者是单号一致数据不一致的提取到另一个表格
    Dim m As Integer, n As Integer, r1 As Integer, r2 As Integer
    Dim Arr(), Brr(), Crr(), Drr(), r%, ra%
    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 8), Drr(1 To r1 - 2, 1 To 4)
    For m = 1 To r2 - 2
        If ds.exists(Brr(m, 2)) Then
            n = ds(Brr(m, 2))
            If Arr(n, 1) = Brr(m, 1) And Arr(n, 3) = Brr(m, 3) Then
                Arr(n, 1) = "": Arr(n, 3) = ""
            Else
                r = r + 1
                If Arr(n, 1) <> "" Then ra = ra + 1
                For i = 1 To 4
                    Crr(r, i) = Brr(m, i)
                    If Arr(n, 1) <> "" Then
                        Crr(r, i + 4) = Arr(n, i)
                        Drr(ra, i) = Arr(n, i)
                    End If
                Next
            End If
        Else
            r = r + 1
            For i = 1 To 4
                Crr(r, i) = Brr(m, i)
            Next
        End If
    Next
    For n = 1 To r1 - 2
        If Arr(n, 1) <> "" Then
            ra = ra + 1
            For i = 1 To 4
                Drr(ra, i) = Arr(n, i)
            Next
        End If
    Next
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Range("l2:n2").Value = Range("a2:c2").Value
    Range("a3:d" & r1).Value = Drr
    Range("h3:o" & r2).Value = Crr
    Range("l2:o" & r + 2).Borders.LineStyle = 1
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

sulli112

山菊花 发表于 2024-1-9 09:35
Public Sub dsm_2()
    '找出相同数据并删除,将找不到的单号，或者是单号一致数据不一致的提取到另一个表 ...

不好意思，一直打扰您，第二段代码没有越标下界了，但是会出现图片一二的问题，我想要的是，第二段代码运行之后，左边就是图一的效果，谢谢，图二右边M列默认文本格式，不然单号太长会变成1.8228E+36格式

山菊花

这样改：
                        Crr(r, i + 4) = "'" & Arr(n, i)

sulli112

山菊花 发表于 2024-1-9 11:03
这样改：
                        Crr(r, i + 4) = "'" & Arr(n, i)

那左边这个第一二行数据重复要怎么修改呢，没运行第二段代码之前，是只有一行数据的，运行了第二代码会新增一行重复数据，

山菊花

Public Sub dsm_2()
    '找出相同数据并删除,将找不到的单号，或者是单号一致数据不一致的提取到另一个表格
    Dim m As Integer, n As Integer, r1 As Integer, r2 As Integer
    Dim Arr(), Brr(), Crr(), Drr(), r%, ra%
    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 8), Drr(1 To r1 - 2, 1 To 4)
    For m = 1 To r2 - 2
        If ds.exists(Brr(m, 2)) Then
            n = ds(Brr(m, 2))
            If Arr(n, 1) = Brr(m, 1) And Arr(n, 3) = Brr(m, 3) Then
                Arr(n, 3) = ""
            Else
                r = r + 1
                If Arr(n, 1) <> "" Then ra = ra + 1
                For i = 1 To 4
                    Crr(r, i) = Brr(m, i)
                    If Arr(n, 1) <> "" Then
                        Crr(r, i + 4) = "'" & Arr(n, i)
                        Drr(ra, i) = Arr(n, i)
                    End If
                Next
            End If
            Arr(n, 1) = ""
        Else
            r = r + 1
            For i = 1 To 4
                Crr(r, i) = Brr(m, i)
            Next
        End If
    Next
    For n = 1 To r1 - 2
        If Arr(n, 1) <> "" Then
            ra = ra + 1
            For i = 1 To 4
                Drr(ra, i) = Arr(n, i)
            Next
        End If
    Next
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Range("l2:n2").Value = Range("a2:c2").Value
    Range("a3:d" & r1).Value = Drr
    Range("h3:o" & r2).Value = Crr
    Range("l2:o" & r + 2).Borders.LineStyle = 1
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

sulli112

山菊花 发表于 2024-1-9 12:46
Public Sub dsm_2()
    '找出相同数据并删除,将找不到的单号，或者是单号一致数据不一致的提取到另一个 ...

可以了，非常感谢，祝您在新的一年万事顺意，谢谢