Nhờ cả nhà hỗ trợ giúp cách kiểm tra thời gian theo điều kiện cho trước

[tangoctuan]

F và C của data bạn à, tôi quên nói, sorry! Và cả 2 đk trong cùng 1 lần sort (tức là And)

Sort F tăng dần AND C giảm dần của Excel đảm bảo cột F theo đúng trình tự thời gian trước đã, sau đó mới xét cột C để các ô rỗng ở C xếp xuống dưới cùng. Bạn Sort xong sẽ thấy cột F luôn luôn nhất quán trình tự thời gian từ cũ đến mới.

À đã hiểu, vậy là mình làm như này đúng không?
Bước 1: Sort cột F tăng dần => Sort xong được: Trên cùng là cũ nhất, xuống dưới là mới nhất.
Bước 2: Sort cột C giảm dần => Sort xong được: Các ô rỗng xếp ở dưới cùng, đồng thời khiến cột F vừa sort xong sẽ thay đổi theo nhưng sẽ được thứ tự từ cũ đến mới theo từng thiết bị ở cột C.
Ví dụ sau khi sort xong 2 bước trên thì sẽ ra kết quả như này phải không:

Tỉnh	Thiết bị mang đến	Thiết bị mang đi		Thời điểm đến/đi
G0004HG	GCBEK1018515			30/07/2018 08:35:36
G0004HG	GCBEK1018515			04/04/2019 17:23:34
G0004HG	GCBEK1018515			29/07/2019 13:38:56
G0004HG	GCASK1073163			09/07/2020 08:01:30
G0004HG	GCAET1350389			01/01/2017 00:00:00
G0004HG	GCAET1350389			22/04/2018 19:57:59
G0004HG	GCAET1350389			30/07/2018 15:02:56
G0004HG	GCAET1350389			04/04/2019 17:24:32
G0004HG	010459			14/07/2020 13:06:54
G0004HG		GCBEK1018515		30/07/2018 15:03:30
G0004HG		GCAET1350389		04/04/2019 17:25:11
G0004HG		GCBEK1018515		09/07/2020 07:59:48
G0004HG		GCASK1073163		13/07/2020 22:29:03

Mình hỏi thêm tí là chỉ sort ở cột C thôi chứ cột D (thiết bị mang đi) không cần phải sort đúng không bạn nhỉ?

 

[Maika8008]

Bạn sửa lại chút nhé: sort cột C giảm dần trước, cột F tăng dần sau.

còn code, để tôi xem lại đã, có sự sai sót

 

[Maika8008]

Bạn sửa lại chút nhé: sort cột C giảm dần trước, cột F tăng dần sau.

còn code, để tôi xem lại đã, có sự sai sót

Thay bằng code này:

Sub KiemTraKhaiBao_Fix()
Dim dic As Object, sKey As String
Dim arrD, arrTmp, arrChk, arrN
Dim i As Long, k As Long, j As Long
Dim tmr As Double, DDate As Date

Application.ScreenUpdating = False
arrTmp = Sheet2.Range("B2:F" & Sheet2.Range("B" & Rows.Count).End(xlUp).Row)
Set dic = CreateObject("Scripting.Dictionary")
ReDim arrD(1 To UBound(arrTmp, 1), 1 To 5)
For i = 1 To UBound(arrTmp, 1)
    sKey = UCase(Trim(arrTmp(i, 1)) & "|" & IIf(arrTmp(i, 2) <> "", Trim(arrTmp(i, 2)), Trim(arrTmp(i, 3))))
    If Not dic.Exists(sKey & "-" & 1) Then
        k = k + 1
        dic.Add (sKey & "-" & "1"), k
        arrD(k, 1) = sKey
        arrD(k, 4) = 1
        If arrTmp(i, 2) <> "" Then
            arrD(k, 2) = CDate(arrTmp(i, 5))
        Else
            arrD(k, 3) = CDate(arrTmp(i, 5))
            arrD(k, 2) = CDate([H1])
        End If
    Else
        If arrTmp(i, 2) = "" Then
            For j = 1 To arrD(dic.Item(sKey & "-" & 1), 4)
                If arrD(dic.Item(sKey & "-" & j), 3) = "" Then
                    arrD(dic.Item(sKey & "-" & j), 3) = CDate(arrTmp(i, 5))
                    Exit For
                End If
            Next
        Else
            k = k + 1
            dic.Add (arrD(dic.Item(sKey & "-" & 1), 1) & "-" & (arrD(dic.Item(sKey & "-" & 1), 4) + 1)), k
            arrD(k, 1) = sKey
            arrD(k, 2) = CDate(arrTmp(i, 5))
            arrD(dic.Item(sKey & "-" & 1), 4) = arrD(dic.Item(sKey & "-" & 1), 4) + 1
        End If
    End If
Next
For j = 1 To k
    If arrD(j, 3) = "" Then arrD(j, 3) = Date
Next
Sheet2.Range("H3").Resize(k, 4) = arrD
Set dic = Nothing

arrN = Sheet1.Range("A2:D" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
ReDim arrChk(1 To UBound(arrN, 1), 1 To 1)
For i = 1 To UBound(arrN, 1)
    sKey = UCase(Trim(arrN(i, 1)) & "|" & Trim(arrN(i, 2)))
    For k = 1 To UBound(arrD, 1)
        If sKey = arrD(k, 1) Then
            If CDate(arrN(i, 3)) >= arrD(k, 2) And CDate(arrN(i, 3)) <= arrD(k, 3) And _
               CDate(arrN(i, 4)) >= arrD(k, 2) And CDate(arrN(i, 4)) <= arrD(k, 3) Then
                arrChk(i, 1) = "OK"
                Exit For
            End If
        End If
    Next
    If arrChk(i, 1) = "" Then arrChk(i, 1) = "NOK"
Next
Sheet1.Range("E2").Resize(UBound(arrN, 1), 1) = arrChk

End Sub

Minh họa bằng hình sau: Vùng data đã sort C giảm, F tăng. Điện Biên-Máy B theo trình tự thời gian đã lấy khớp 2 khoảng. Hải Dương chỉ có 1 khoảng nên không vấn đề gì. Còn Hà Nam-Máy D không có ngày đi nên lấy ngày hiện tại, Hà Nam-Máy A không có ngày đến nên lấy ngày tại ô H1. VẬY BẠN ĐIỀN NGÀY NHỎ NHẤT CẦN LẤY VÀO Ô H1 TRƯỚC KHI CHẠY CODE NHÉ!

 

[tangoctuan]

Thay bằng code này:

Sub KiemTraKhaiBao_Fix()
Dim dic As Object, sKey As String
Dim arrD, arrTmp, arrChk, arrN
Dim i As Long, k As Long, j As Long
Dim tmr As Double, DDate As Date

Application.ScreenUpdating = False
arrTmp = Sheet2.Range("B2:F" & Sheet2.Range("B" & Rows.Count).End(xlUp).Row)
Set dic = CreateObject("Scripting.Dictionary")
ReDim arrD(1 To UBound(arrTmp, 1), 1 To 5)
For i = 1 To UBound(arrTmp, 1)
    sKey = UCase(Trim(arrTmp(i, 1)) & "|" & IIf(arrTmp(i, 2) <> "", Trim(arrTmp(i, 2)), Trim(arrTmp(i, 3))))
    If Not dic.Exists(sKey & "-" & 1) Then
        k = k + 1
        dic.Add (sKey & "-" & "1"), k
        arrD(k, 1) = sKey
        arrD(k, 4) = 1
        If arrTmp(i, 2) <> "" Then
            arrD(k, 2) = CDate(arrTmp(i, 5))
        Else
            arrD(k, 3) = CDate(arrTmp(i, 5))
            arrD(k, 2) = CDate([H1])
        End If
    Else
        If arrTmp(i, 2) = "" Then
            For j = 1 To arrD(dic.Item(sKey & "-" & 1), 4)
                If arrD(dic.Item(sKey & "-" & j), 3) = "" Then
                    arrD(dic.Item(sKey & "-" & j), 3) = CDate(arrTmp(i, 5))
                    Exit For
                End If
            Next
        Else
            k = k + 1
            dic.Add (arrD(dic.Item(sKey & "-" & 1), 1) & "-" & (arrD(dic.Item(sKey & "-" & 1), 4) + 1)), k
            arrD(k, 1) = sKey
            arrD(k, 2) = CDate(arrTmp(i, 5))
            arrD(dic.Item(sKey & "-" & 1), 4) = arrD(dic.Item(sKey & "-" & 1), 4) + 1
        End If
    End If
Next
For j = 1 To k
    If arrD(j, 3) = "" Then arrD(j, 3) = Date
Next
Sheet2.Range("H3").Resize(k, 4) = arrD
Set dic = Nothing

arrN = Sheet1.Range("A2:D" & Sheet1.Range("A" & Rows.Count).End(xlUp).Row)
ReDim arrChk(1 To UBound(arrN, 1), 1 To 1)
For i = 1 To UBound(arrN, 1)
    sKey = UCase(Trim(arrN(i, 1)) & "|" & Trim(arrN(i, 2)))
    For k = 1 To UBound(arrD, 1)
        If sKey = arrD(k, 1) Then
            If CDate(arrN(i, 3)) >= arrD(k, 2) And CDate(arrN(i, 3)) <= arrD(k, 3) And _
               CDate(arrN(i, 4)) >= arrD(k, 2) And CDate(arrN(i, 4)) <= arrD(k, 3) Then
                arrChk(i, 1) = "OK"
                Exit For
            End If
        End If
    Next
    If arrChk(i, 1) = "" Then arrChk(i, 1) = "NOK"
Next
Sheet1.Range("E2").Resize(UBound(arrN, 1), 1) = arrChk

End Sub

Minh họa bằng hình sau: Vùng data đã sort C giảm, F tăng. Điện Biên-Máy B theo trình tự thời gian đã lấy khớp 2 khoảng. Hải Dương chỉ có 1 khoảng nên không vấn đề gì. Còn Hà Nam-Máy D không có ngày đi nên lấy ngày hiện tại, Hà Nam-Máy A không có ngày đến nên lấy ngày tại ô H1. VẬY BẠN ĐIỀN NGÀY NHỎ NHẤT CẦN LẤY VÀO Ô H1 TRƯỚC KHI CHẠY CODE NHÉ!
View attachment 260794

Đã làm theo hướng dẫn và kết quả ra chính xác. Một lần nữa xin cảm ơn bạn rất nhiều!

 

[HieuCD]

Bạn xem lại thử.

Code chuyển thời gian theo dạng chuẩn và tự sort dữ liệu theo 3 cột nên không cần dictionary

Option Explicit
Sub XYZ()
  Dim aData(), aKB(), Res(), sRow&, sR&, i&, r&, k&
  Dim tinh$, may$, fTime, eTime, tmp, iTime
  Dim den As Boolean, di As Boolean, thoa As Boolean, bd As Boolean
 
  aKB = Sheet1.Range("A2", Sheet1.Range("D" & Rows.Count).End(xlUp)).Value
  ReDim Res(1 To UBound(aKB), 1 To 1)
  With Sheet2
    aData = .Range("B2", Sheet2.Range("F" & Rows.Count).End(xlUp)).Value
    sRow = UBound(aData)
    For r = 1 To sRow
      aData(r, 4) = aData(r, 2) & aData(r, 3)
      tmp = aData(r, 5)
      aData(r, 5) = CDate(Mid(tmp, 7, 4) & Mid(tmp, 3, 4) & Mid(tmp, 1, 2) & Mid(tmp, 11, 9))
    Next r
    .Range("H2").Resize(sRow, 5) = aData
    .Range("H2").Resize(sRow, 5).Sort .Range("H2"), 1, .Range("K2"), , 1, .Range("L2"), 1, xlNo
    sRow = sRow + 1
    aData = .Range("H2").Resize(sRow, 5).Value
    .Range("H2").Resize(sRow, 5).ClearContents
  End With
  sR = UBound(aKB)
  For i = 1 To sR
    tinh = aKB(i, 1): may = aKB(i, 2)
    tmp = aKB(i, 3)
    fTime = CDate(Mid(tmp, 7, 4) & Mid(tmp, 3, 4) & Mid(tmp, 1, 2) & Mid(tmp, 11, 9))
    tmp = aKB(i, 4)
    eTime = CDate(Mid(tmp, 7, 4) & Mid(tmp, 3, 4) & Mid(tmp, 1, 2) & Mid(tmp, 11, 9))
    Res(i, 1) = "No": thoa = False: bd = False: di = False: den = False
    For r = 1 To sRow
      If aData(r, 1) = tinh And aData(r, 4) = may Then
          If thoa = False Then thoa = True
          iTime = aData(r, 5)
          If aData(r, 2) = may Then 'TB Den
            If bd = False Then bd = True
            If iTime < fTime Then den = True Else den = False
          Else 'TB Di
            If iTime >= eTime Then
              If bd = False Then den = True
              di = True
              If di = True And den = True Then Res(i, 1) = "Ok": Exit For
            Else
              di = False
            End If
            If bd = False Then bd = True
          End If
      Else
        If thoa = True Then
          If den = True Then Res(i, 1) = "Ok"
          Exit For
        End If
      End If
    Next r
  Next i
  Sheet1.Range("E2").Resize(sR) = Res
End Sub