Kiểm tra dữ liệu trùng tại hai thời điểm liên tiếp!

[huuthang_bd]

Mình cũng dùng máy win 10, 64bit, ram 12Gb và chạy vẫn báo lỗi như vậy? Hix, không biết có bạn nào trong diễn đàn chỉ giúp!

Tạm thời sửa lại code xem máy bạn có chạy được không đã, chưa xét ưu tiên nhé.
Code này tôi không dùng Dictionary, có vẻ nhanh hơn.

Sub KhongUuTien()
Dim Data As Variant, i As Long, Result(1 To 1440, 1 To 2) As Long
Dim ArrInfo(0 To 1439, 0 To 36, 0 To 36) As Boolean
Data = Range(Cells(&H100000, 1).End(xlUp), Cells(2, 2)).Value
For i = 1 To UBound(Data, 1) - 1
    ArrInfo(TimeValue(Data(i, 1)) * 60 * 24, Data(i, 2), Data(i + 1, 2)) = True
Next
Erase Data
Result(1, 1) = Range("E2").Value
Result(1, 2) = Range("F2").Value
x = -1
For Pos = 1 To 1439
    For i = x + 1 To 36
        If Not (ArrInfo(Pos, Result(Pos, 1), i) Or ArrInfo(Pos, Result(Pos, 2), i)) Then
            If x < 0 Then
                x = i
            Else
                Result(Pos + 1, 1) = x
                Result(Pos + 1, 2) = i
                x = -1
                Exit For
            End If
        End If
    Next
    If i > 36 Then
        If Pos > 1 Then
            x = Result(Pos, 2)
            Pos = Pos - 2
        Else
            MsgBox "Khong co ket qua thoa dieu kien"
            Exit Sub
        End If
    End If
Next
Range("E2:F1441").Value = Result
End Sub

 

[TheThienChu]

Tạm thời sửa lại code xem máy bạn có chạy được không đã, chưa xét ưu tiên nhé.
Code này tôi không dùng Dictionary, có vẻ nhanh hơn.

Sub KhongUuTien()
Dim Data As Variant, i As Long, Result(1 To 1440, 1 To 2) As Long
Dim ArrInfo(0 To 1439, 0 To 36, 0 To 36) As Boolean
Data = Range(Cells(&H100000, 1).End(xlUp), Cells(2, 2)).Value
For i = 1 To UBound(Data, 1) - 1
    ArrInfo(TimeValue(Data(i, 1)) * 60 * 24, Data(i, 2), Data(i + 1, 2)) = True
Next
Erase Data
Result(1, 1) = Range("E2").Value
Result(1, 2) = Range("F2").Value
x = -1
For Pos = 1 To 1439
    For i = x + 1 To 36
        If Not (ArrInfo(Pos, Result(Pos, 1), i) Or ArrInfo(Pos, Result(Pos, 2), i)) Then
            If x < 0 Then
                x = i
            Else
                Result(Pos + 1, 1) = x
                Result(Pos + 1, 2) = i
                x = -1
                Exit For
            End If
        End If
    Next
    If i > 36 Then
        If Pos > 1 Then
            x = Result(Pos, 2)
            Pos = Pos - 2
        Else
            MsgBox "Khong co ket qua thoa dieu kien"
            Exit Sub
        End If
    End If
Next
Range("E2:F1441").Value = Result
End Sub

Có cách nào nhanh hơn nữa không bạn

 

[huuthang_bd]

Ưu tiên tần suất xuất hiện từ thấp đến cao; cho phép sử dụng nhiều vùng dữ liệu nguồn. Áp dụng cho file ở bài #54.

Sub Test()
Main Sheet1.Range("A2:B1044260"), Sheet2.Range("A2:B54790")
End Sub

Private Sub Main(ParamArray Args() As Variant)
Dim Data As Variant, i As Long, x As Long, Result(1 To 1440, 1 To 2) As Long
Dim ArrInfo(0 To 1439, 0 To 36, 0 To 36) As Boolean
For x = LBound(Args) To UBound(Args)
    Data = Args(x).Value
    For i = 1 To UBound(Data, 1) - 1
        ArrInfo(TimeValue(Data(i, 1)) * 1440, Data(i, 2), Data(i + 1, 2)) = True
    Next
    Erase Data
Next
Data = Range("G2:AQ1441").Value
SortFrequency Data
Result(1, 1) = Range("E2").Value
Result(1, 2) = Range("F2").Value
x = 0
For Pos = 1 To 1439
    For i = x + 1 To 37
        If Not (ArrInfo(Pos, Result(Pos, 1), Data(Pos + 1, i)) Or ArrInfo(Pos, Result(Pos, 2), Data(Pos + 1, i))) Then
            If x = 0 Then
                x = i
            Else
                Result(Pos + 1, 1) = Data(Pos + 1, x)
                Result(Pos + 1, 2) = Data(Pos + 1, i)
                x = 0
                Exit For
            End If
        End If
    Next
    If i > 37 Then
        If Pos > 1 Then
            For x = 1 To 37
                If Result(Pos, 2) = Data(Pos, x) Then Exit For
            Next
            Pos = Pos - 2
        Else
            MsgBox "Khong co ket qua thoa dieu kien"
            Exit Sub
        End If
    End If
Next
Range("E2:F1441").Value = Result
End Sub

Private Sub SortFrequency(ByRef Data As Variant)
Dim IndexArr(1 To 37) As Long, SortArr As Variant
Dim i As Long, j As Long, k As Long, Tmp As Long
For i = 1 To 37
    IndexArr(i) = i - 1
Next
For i = 1 To UBound(Data, 1)
    SortArr = IndexArr
    For j = 1 To 36
        For k = j + 1 To 37
            If Data(i, k) < Data(i, j) Then
                Tmp = Data(i, k): Data(i, k) = Data(i, j): Data(i, j) = Tmp
                Tmp = SortArr(k): SortArr(k) = SortArr(j): SortArr(j) = Tmp
            End If
        Next
    Next
    For j = 1 To 37
        Data(i, j) = SortArr(j)
    Next
Next
End Sub

 

[Sơn Mã]

Ưu tiên tần suất xuất hiện từ thấp đến cao; cho phép sử dụng nhiều vùng dữ liệu nguồn. Áp dụng cho file ở bài #54.

Sub Test()
Main Sheet1.Range("A2:B1044260"), Sheet2.Range("A2:B54790")
End Sub

Private Sub Main(ParamArray Args() As Variant)
Dim Data As Variant, i As Long, x As Long, Result(1 To 1440, 1 To 2) As Long
Dim ArrInfo(0 To 1439, 0 To 36, 0 To 36) As Boolean
For x = LBound(Args) To UBound(Args)
    Data = Args(x).Value
    For i = 1 To UBound(Data, 1) - 1
        ArrInfo(TimeValue(Data(i, 1)) * 1440, Data(i, 2), Data(i + 1, 2)) = True
    Next
    Erase Data
Next
Data = Range("G2:AQ1441").Value
SortFrequency Data
Result(1, 1) = Range("E2").Value
Result(1, 2) = Range("F2").Value
x = 0
For Pos = 1 To 1439
    For i = x + 1 To 37
        If Not (ArrInfo(Pos, Result(Pos, 1), Data(Pos + 1, i)) Or ArrInfo(Pos, Result(Pos, 2), Data(Pos + 1, i))) Then
            If x = 0 Then
                x = i
            Else
                Result(Pos + 1, 1) = Data(Pos + 1, x)
                Result(Pos + 1, 2) = Data(Pos + 1, i)
                x = 0
                Exit For
            End If
        End If
    Next
    If i > 37 Then
        If Pos > 1 Then
            For x = 1 To 37
                If Result(Pos, 2) = Data(Pos, x) Then Exit For
            Next
            Pos = Pos - 2
        Else
            MsgBox "Khong co ket qua thoa dieu kien"
            Exit Sub
        End If
    End If
Next
Range("E2:F1441").Value = Result
End Sub

Private Sub SortFrequency(ByRef Data As Variant)
Dim IndexArr(1 To 37) As Long, SortArr As Variant
Dim i As Long, j As Long, k As Long, Tmp As Long
For i = 1 To 37
    IndexArr(i) = i - 1
Next
For i = 1 To UBound(Data, 1)
    SortArr = IndexArr
    For j = 1 To 36
        For k = j + 1 To 37
            If Data(i, k) < Data(i, j) Then
                Tmp = Data(i, k): Data(i, k) = Data(i, j): Data(i, j) = Tmp
                Tmp = SortArr(k): SortArr(k) = SortArr(j): SortArr(j) = Tmp
            End If
        Next
    Next
    For j = 1 To 37
        Data(i, j) = SortArr(j)
    Next
Next
End Sub

Vâng, dạ cảm ơn bạn nhiều quá. Chúc bạn một ngày làm việc thành công!