[Giúp] VBA copy ngày có điều kiện từ nhiều sheet qua sheet kết quả

[robinhsoon]

Thân chào cả nhà GPEX!
Mong cả nhà giúp em một việc ạ.
Hiện tại em có một File data bao gồm hơn 20 sheet - em chỉ làm demo 3 sheet cho nhẹ File ạ.
mục đích của em là:
Khi em input ngày vào cột I3 (sheet KetQua) thì các công việc của các sheet sẽ tự nhảy vào sheet kết quả (dựa vào cột Date của các sheet làm điều kiện)
Ví dụ:
Em Input 25/03/2019 thì các công việc của ngày 25/03/2019 sẽ nhảy qua sheet kết quả.

Em có làm thử kết quả như File ạ.
Mong cả nhà giúp đỡ, em chân thành cảm ơn ạ.

 

[Ba Tê]

Thân chào cả nhà GPEX!
Mong cả nhà giúp em một việc ạ.
Hiện tại em có một File data bao gồm hơn 20 sheet - em chỉ làm demo 3 sheet cho nhẹ File ạ.
mục đích của em là:
Khi em input ngày vào cột I3 (sheet KetQua) thì các công việc của các sheet sẽ tự nhảy vào sheet kết quả (dựa vào cột Date của các sheet làm điều kiện)
Ví dụ:
Em Input 25/03/2019 thì các công việc của ngày 25/03/2019 sẽ nhảy qua sheet kết quả.

Em có làm thử kết quả như File ạ.
Mong cả nhà giúp đỡ, em chân thành cảm ơn ạ.

Bạn thử Sub này coi sao:

Option Explicit

Public Sub s_Gpe()
Application.ScreenUpdating = False
Const CoL As Long = 9
Dim Ws As Worksheet, sArr(), dArr(), Ngay As Date
Dim I As Long, J As Long, K As Long, R As Long
ReDim dArr(1 To 1000, 1 To CoL)
Ngay = Sheets("KetQua").Range("I3").Value
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> "KetQua" Then
        If Ws.Range("A10000").End(xlUp).Row > 5 Then
            sArr = Ws.Range("A4", Ws.Range("A10000").End(xlUp)).Resize(, CoL).Value
            R = UBound(sArr)
            For I = 1 To R
                If sArr(I, CoL) = Ngay Then
                    K = K + 1
                    For J = 1 To CoL
                        dArr(K, J) = sArr(I, J)
                    Next J
                End If
            Next I
        End If
    End If
Next Ws
With Sheets("KetQua")
    .Range("A6").Resize(1000, CoL).ClearContents
    .Range("A6").Resize(1000, CoL).Borders.LineStyle = 0
    If K Then
        .Range("A6").Resize(K, CoL) = dArr
        .Range("A6").Resize(K, CoL).Borders.LineStyle = 1
    End If
End With
End Sub

 

[robinhsoon]

Bạn thử Sub này coi sao:

Option Explicit

Public Sub s_Gpe()
Application.ScreenUpdating = False
Const CoL As Long = 9
Dim Ws As Worksheet, sArr(), dArr(), Ngay As Date
Dim I As Long, J As Long, K As Long, R As Long
ReDim dArr(1 To 1000, 1 To CoL)
Ngay = Sheets("KetQua").Range("I3").Value
For Each Ws In ThisWorkbook.Worksheets
    If Ws.Name <> "KetQua" Then
        If Ws.Range("A10000").End(xlUp).Row > 5 Then
            sArr = Ws.Range("A4", Ws.Range("A10000").End(xlUp)).Resize(, CoL).Value
            R = UBound(sArr)
            For I = 1 To R
                If sArr(I, CoL) = Ngay Then
                    K = K + 1
                    For J = 1 To CoL
                        dArr(K, J) = sArr(I, J)
                    Next J
                End If
            Next I
        End If
    End If
Next Ws
With Sheets("KetQua")
    .Range("A6").Resize(1000, CoL).ClearContents
    .Range("A6").Resize(1000, CoL).Borders.LineStyle = 0
    If K Then
        .Range("A6").Resize(K, CoL) = dArr
        .Range("A6").Resize(K, CoL).Borders.LineStyle = 1
    End If
End With
End Sub

Em cảm ơn Thầy ạ, code hay và nhanh lắm ạ..

Chúc Thầy sức khỏe và thành công ạ