Code lọc dữ liệu liên tục theo điều kiện

[hic1802]

Xin chào mọi người trên GPE,
Em có chế code lọc dữ liệu từ 1 sheets trên cùng 1 file excel (lấy dữ liệu từ sheet "BCN" sang sheet "Form_BC"
đây là code chế nhưng mà nó chạy không đúng ý, nhờ mọi người chỉnh sửa cho đúng ạ
Ý em muốn là lọc lấy dữ liệu của ngày hôm nay và ngày hôm sau, như dữ liệu ở "form_BC"
e chạy chỉ có lọc dữ liệu đúng ngày, còn ngày hôm sau thì chạy lỗi

Dim sArr(), dAtt(), I As Long, J As Long, K As Long, R As Long, lr As Long, darr(), q As Long
On Error Resume Next
With Sheets("BCN")
    sArr = .Range("b3", .Range("b60000").End(xlUp)).Resize(, 14).Value
    R = UBound(sArr)
End With
ReDim darr(1 To R, 1 To 12)

With Sheets("Form_BC")
    'Tem = .Range("D2").Value
    For I = 1 To R
        If sArr(I, 1) = [g2].Value Then
                K = K + 1
                darr(K, 1) = K
                For J = 2 To 8
                    darr(K, J) = sArr(I, J)
                Next J
                For J = 9 To 12
                    darr(K, J) = sArr(I, J + 2)
                Next J
        End If
    Next I
    .Range("A5:L999").ClearContents
    .Range("A6").Resize(24, 999).Borders.LineStyle = 0
    If K Then
        .Range("a5:L5").Resize(K) = darr
        .Range("a6").Resize(K, 12).Borders.LineStyle = 1
    End If
    lr = .Cells(Rows.Count, "A").End(xlUp).Row + 2
    .Range("A" & lr) = .Range("K2").Value
    .Range("A" & lr).HorizontalAlignment = xlGeneral
    .Range("A" & lr).Font.Bold = True
    ReDim darr(1 To R, 1 To 6)
    For I = 1 To R
        If sArr(I, 1) = [l2].Value Then
            q = q + 1
            darr(q, 1) = q
            For J = 2 To 6
                darr(q, J) = sArr(I, J)
            Next J
        End If
    Next I
    If q Then
        .Range("a:" & lr + 1 & ":F:" & lr + 1).Resize(q, 5) = darr
        .Range("a" & lr + 1).Resize(q, 5).Borders.LineStyle = 1
    End If
   
    '.Range("A" & lr + 1).Resize(2, 12).Borders.LineStyle = 1
    '.Range("B" & lr + 4) = .Range("i2").Value
    '.Range("B" & lr + 4).WrapText = False
    '.Range("j" & lr + 4) = .Range("j2").Value
    '.Range("j" & lr + 4).WrapText = False
    '.Range("A4:L4").AutoFilter
End With

 

[snow25]

Xin chào mọi người trên GPE,
Em có chế code lọc dữ liệu từ 1 sheets trên cùng 1 file excel (lấy dữ liệu từ sheet "BCN" sang sheet "Form_BC"
đây là code chế nhưng mà nó chạy không đúng ý, nhờ mọi người chỉnh sửa cho đúng ạ
Ý em muốn là lọc lấy dữ liệu của ngày hôm nay và ngày hôm sau, như dữ liệu ở "form_BC"
e chạy chỉ có lọc dữ liệu đúng ngày, còn ngày hôm sau thì chạy lỗi

Dim sArr(), dAtt(), I As Long, J As Long, K As Long, R As Long, lr As Long, darr(), q As Long
On Error Resume Next
With Sheets("BCN")
    sArr = .Range("b3", .Range("b60000").End(xlUp)).Resize(, 14).Value
    R = UBound(sArr)
End With
ReDim darr(1 To R, 1 To 12)

With Sheets("Form_BC")
    'Tem = .Range("D2").Value
    For I = 1 To R
        If sArr(I, 1) = [g2].Value Then
                K = K + 1
                darr(K, 1) = K
                For J = 2 To 8
                    darr(K, J) = sArr(I, J)
                Next J
                For J = 9 To 12
                    darr(K, J) = sArr(I, J + 2)
                Next J
        End If
    Next I
    .Range("A5:L999").ClearContents
    .Range("A6").Resize(24, 999).Borders.LineStyle = 0
    If K Then
        .Range("a5:L5").Resize(K) = darr
        .Range("a6").Resize(K, 12).Borders.LineStyle = 1
    End If
    lr = .Cells(Rows.Count, "A").End(xlUp).Row + 2
    .Range("A" & lr) = .Range("K2").Value
    .Range("A" & lr).HorizontalAlignment = xlGeneral
    .Range("A" & lr).Font.Bold = True
    ReDim darr(1 To R, 1 To 6)
    For I = 1 To R
        If sArr(I, 1) = [l2].Value Then
            q = q + 1
            darr(q, 1) = q
            For J = 2 To 6
                darr(q, J) = sArr(I, J)
            Next J
        End If
    Next I
    If q Then
        .Range("a:" & lr + 1 & ":F:" & lr + 1).Resize(q, 5) = darr
        .Range("a" & lr + 1).Resize(q, 5).Borders.LineStyle = 1
    End If
  
    '.Range("A" & lr + 1).Resize(2, 12).Borders.LineStyle = 1
    '.Range("B" & lr + 4) = .Range("i2").Value
    '.Range("B" & lr + 4).WrapText = False
    '.Range("j" & lr + 4) = .Range("j2").Value
    '.Range("j" & lr + 4).WrapText = False
    '.Range("A4:L4").AutoFilter
End With

Bạn sửa chỗ gần cuối thành vậy.

.Range("a" & lr + 1).Resize(q, 5) = darr

 

[hic1802]

Bạn sửa chỗ gần cuối thành vậy.

.Range("a" & lr + 1).Resize(q, 5) = darr

mình sửa nhưng ko đc, mình tìm đc phương án rồi, phải sửa thành :
.Range(cells(lr+1,"A"),cells(lr+1,"J")).Resize(q) = darr