Hỗ trợ xóa ngày lớn hơn ngày ở Sheet1

[Vincentpham6879]

Chào các anh/chị, em có trường hợp muốn xóa dữ liệu.
Dữ liệu so sánh của em là Sheet1.Range("A2")
Ở Sheet2, dựa vào cột B, nếu dữ liệu nào lớn hơn cột A2 ở Sheet1 thì xóa đi.
Ví dụ, A2 ở Sheet1 của em đang là 12.12.2023, ở Sheet2 nếu ngày nào lớn hơn ngày 12 trong trường hợp này thì các dòng có tô đỏ ở Sheet2 sẽ xóa đi.
Lưu ý là dữ liệu định dạng ngày tháng đang là text.
Nhờ anh/chị giúp em trường hợp này, em cám ơn nhiều.

 

[snow25]

Bạn thử code này.

Sub abc()
   Dim a As Long, b As Long, arr, kq, c As Long, lr As Long, i As Long
   With Sheets("sheet1")
       a = DateSerial(Mid(.Range("a2").Value, 7, 4), Mid(.Range("a2").Value, 4, 2), Left(.Range("A2").Value, 2))
   End With
   With Sheets("sheet2")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr = 1 Then Exit Sub
       arr = .Range("a2:C" & lr).Value
       ReDim kq(1 To UBound(arr), 1 To 3)
       For i = 1 To UBound(arr)
           b = DateSerial(Mid(arr(i, 2), 7, 4), Mid(arr(i, 2), 4, 2), Left(arr(i, 2), 2))
           If a > b Then
              c = c + 1
              kq(c, 1) = arr(i, 1)
              kq(c, 2) = arr(i, 2)
              kq(c, 3) = arr(i, 3)
           End If
       Next i
       .Range("a2:C" & lr).ClearContents
       If c Then .Range("a2:C2").Resize(c).Value = kq
   End With
End Sub

 

[Vincentpham6879]

Bạn thử code này.

Sub abc()
   Dim a As Long, b As Long, arr, kq, c As Long, lr As Long, i As Long
   With Sheets("sheet1")
       a = DateSerial(Mid(.Range("a2").Value, 7, 4), Mid(.Range("a2").Value, 4, 2), Left(.Range("A2").Value, 2))
   End With
   With Sheets("sheet2")
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr = 1 Then Exit Sub
       arr = .Range("a2:C" & lr).Value
       ReDim kq(1 To UBound(arr), 1 To 3)
       For i = 1 To UBound(arr)
           b = DateSerial(Mid(arr(i, 1), 7, 4), Mid(arr(i, 1), 4, 2), Left(arr(i, 1), 2))
           If a > b Then
              c = c + 1
              kq(c, 1) = arr(i, 1)
              kq(c, 2) = arr(i, 2)
              kq(c, 3) = arr(i, 3)
           End If
       Next i
       .Range("a2:C" & lr).ClearContents
       If c Then .Range("a2:C2").Resize(c).Value = kq
   End With
End Sub

Dạ anh ơi, em cám ơn anh đã giúp đỡ. Cho em hỏi thêm xíu, ví dụ trong trường hợp em chỉ muốn xóa dữ liệu thôi chứ không cần phải dồn dữ liệu lên trên thì sửa như nào ạ ? Em cám ơn anh nhiều !

 

[SA_DQ]

Thì xài cập cha con rùa này:

Sub XoaNgay()
 Dim Rws As Long, J As Long
 
 With Sheet2
    Rws = .[b2].CurrentRegion.Rows.Count
    For J = 2 To Rws
        If TxtToDate(.Cells(J, "B").Value) > TxtToDate(Sheet1.[A2].Value) Then _
            .Cells(J, "D").Resize(, 4).Value = "GPE"
    Next J
 End With
End Sub

Function TxtToDate(StrC As String) As Date
 TxtToDate = DateSerial(CInt(Right(StrC, 4)), CInt(Mid(StrC, 4, 2)), CInt(Left(StrC, 2)))
End Function

 

[Vincentpham6879]

Thì xài cập cha con rùa này:

Sub XoaNgay()
 Dim Rws As Long, J As Long
 
 With Sheet2
    Rws = .[b2].CurrentRegion.Rows.Count
    For J = 2 To Rws
        If TxtToDate(.Cells(J, "B").Value) > TxtToDate(Sheet1.[A2].Value) Then _
            .Cells(J, "D").Resize(, 4).Value = "GPE"
    Next J
 End With
End Sub

Function TxtToDate(StrC As String) As Date
 TxtToDate = DateSerial(CInt(Right(StrC, 4)), CInt(Mid(StrC, 4, 2)), CInt(Left(StrC, 2)))
End Function

Dạ em làm được rồi, em cám ơn anh nhiều.