Tách sheet theo điều kiện cột ngày nhưng cột ngày không định dạng kiểu dd/mm/yyyy

[hoahuongduong1986]

Kính gửi anh chị,
Tiếp theo vấn đề dùng Dic trong excel, em có mày mò và làm code tách sheet như File. Nhưng giờ em muốn tách sheet và có thêm điều kiện lấy trong khoảng thời gian như tại cột K1 và K2. Tuy nhiên, cột A - ngày tháng nếu ở tình trạng như File thì không chạy được vì chỉ hiểu là text. Có cách gì để xử lý cột arr(i,1) để lọc và tách sheet được không ạ. Em cảm ơn ạ !

 

[Nhattanktnn]

Kính gửi anh chị,
Tiếp theo vấn đề dùng Dic trong excel, em có mày mò và làm code tách sheet như File. Nhưng giờ em muốn tách sheet và có thêm điều kiện lấy trong khoảng thời gian như tại cột K1 và K2. Tuy nhiên, cột A - ngày tháng nếu ở tình trạng như File thì không chạy được vì chỉ hiểu là text. Có cách gì để xử lý cột arr(i,1) để lọc và tách sheet được không ạ. Em cảm ơn ạ !

Dùng hàm dateserial kết hơp mấy hàm mid, left,right gì đó tùy bạn

 

[Cá ngừ F1]

Biến cột đầu thành đúng định dạng dd/mm/yyyy thử xem sao.

 

[vanthinh3101]

Kính gửi anh chị,
Tiếp theo vấn đề dùng Dic trong excel, em có mày mò và làm code tách sheet như File. Nhưng giờ em muốn tách sheet và có thêm điều kiện lấy trong khoảng thời gian như tại cột K1 và K2. Tuy nhiên, cột A - ngày tháng nếu ở tình trạng như File thì không chạy được vì chỉ hiểu là text. Có cách gì để xử lý cột arr(i,1) để lọc và tách sheet được không ạ. Em cảm ơn ạ !

Sửa lại code của bạn 1 chút.
Bạn tham khảo nhé!

Sub LOC_DU_LIEU()

    Application.ScreenUpdating = False
    Dim dic As Object
    Dim arr(), kq()
    Dim i, j, a, lr As Long, key As Variant
    Dim Header As Range, Ws As Worksheet
    
    Set Header = Sheet1.Range("A1:H1")
    Set dic = CreateObject("Scripting.Dictionary")
    lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    arr = Sheet1.Range("A2:H" & lr).Value
    For i = 1 To UBound(arr, 1)
        If Not dic.exists(arr(i, 3)) Then
       ' And arr(i, 1) >= Sheet1.Range("K1").Value _
        'And arr(i, 1) <= Sheet1.Range("K2").Value Then
        dic.Add arr(i, 3), arr(i, 3)
        End If
    Next
    For Each key In dic.keys
        ReDim kq(1 To UBound(arr, 1), 1 To 9)
        a = 0
        For j = 1 To UBound(arr, 1)
            If arr(j, 3) = dic(key) Then
                If CDate(Sheet1.Range("K1")) <= DateSerial(Left(arr(j, 1), 4), Mid(arr(j, 1), 5, 2), Right(arr(j, 1), 2)) And _
                    CDate(Sheet1.Range("K2")) >= DateSerial(Left(arr(j, 1), 4), Mid(arr(j, 1), 5, 2), Right(arr(j, 1), 2)) Then
                    a = a + 1
                    kq(a, 1) = a
                    kq(a, 2) = arr(j, 1)
                    kq(a, 3) = arr(j, 2)
                    kq(a, 4) = arr(j, 3)
                    kq(a, 5) = arr(j, 4)
                    kq(a, 6) = arr(j, 5)
                    kq(a, 7) = arr(j, 6)
                    kq(a, 8) = arr(j, 7)
                    kq(a, 9) = arr(j, 8)
                End If
            End If
        Next j
        
        If a Then
            Set Ws = Worksheets.Add(, Worksheets(Worksheets.Count))
            With Ws
               .Name = dic(key)
               Header.Copy .Range("B1")
               .Range("A1") = "Number"
               .Range("A2").Resize(a, 9).Value = kq()
            End With
        End If
    Next key
    
    Set Header = Nothing: Set dic = Nothing: Set Ws = Nothing
    Application.ScreenUpdating = True

End Sub

 

[hoahuongduong1986]

Sửa lại code của bạn 1 chút.
Bạn tham khảo nhé!

Sub LOC_DU_LIEU()

    Application.ScreenUpdating = False
    Dim dic As Object
    Dim arr(), kq()
    Dim i, j, a, lr As Long, key As Variant
    Dim Header As Range, Ws As Worksheet
   
    Set Header = Sheet1.Range("A1:H1")
    Set dic = CreateObject("Scripting.Dictionary")
    lr = Sheet1.Range("A" & Rows.Count).End(xlUp).Row
    arr = Sheet1.Range("A2:H" & lr).Value
    For i = 1 To UBound(arr, 1)
        If Not dic.exists(arr(i, 3)) Then
       ' And arr(i, 1) >= Sheet1.Range("K1").Value _
        'And arr(i, 1) <= Sheet1.Range("K2").Value Then
        dic.Add arr(i, 3), arr(i, 3)
        End If
    Next
    For Each key In dic.keys
        ReDim kq(1 To UBound(arr, 1), 1 To 9)
        a = 0
        For j = 1 To UBound(arr, 1)
            If arr(j, 3) = dic(key) Then
                If CDate(Sheet1.Range("K1")) <= DateSerial(Left(arr(j, 1), 4), Mid(arr(j, 1), 5, 2), Right(arr(j, 1), 2)) And _
                    CDate(Sheet1.Range("K2")) >= DateSerial(Left(arr(j, 1), 4), Mid(arr(j, 1), 5, 2), Right(arr(j, 1), 2)) Then
                    a = a + 1
                    kq(a, 1) = a
                    kq(a, 2) = arr(j, 1)
                    kq(a, 3) = arr(j, 2)
                    kq(a, 4) = arr(j, 3)
                    kq(a, 5) = arr(j, 4)
                    kq(a, 6) = arr(j, 5)
                    kq(a, 7) = arr(j, 6)
                    kq(a, 8) = arr(j, 7)
                    kq(a, 9) = arr(j, 8)
                End If
            End If
        Next j
       
        If a Then
            Set Ws = Worksheets.Add(, Worksheets(Worksheets.Count))
            With Ws
               .Name = dic(key)
               Header.Copy .Range("B1")
               .Range("A1") = "Number"
               .Range("A2").Resize(a, 9).Value = kq()
            End With
        End If
    Next key
   
    Set Header = Nothing: Set dic = Nothing: Set Ws = Nothing
    Application.ScreenUpdating = True

End Sub

Hay quá anh, em cảm ơn nhiều ạ !