Nhờ giúp sửa lỗi và hoàn thiện code trích xuất dữ liệu (1 người xem)

[luclamchamtim]

Mình có 1 bảng dữ liệu nằm trong sheet "123" muốn lấy dữ liệu ở đó đưa vào 3 sheet còn lại "GA", "VMT", "JQ"
theo tên máy, máy nào thì copy vào ô máy đó ( cụ thể xem file đính kèm các bác sẽ hiểu rõ hơn)
Mình cũng bập bõm tự tìm hiểu về VBA với học thêm được ở các ví dụ trong forum nên cũng đã viết được 1 đoạn code nhưng nó hoạt động không theo ý mình nên nhờ các bác sửa giúp và hoàn thiện giúp mình nhé
Cảm ơn!

 

[luclamchamtim]

Chạy code này.

Public Sub GPE()
Dim Dic As Object, Ws As Worksheet, sArr, dArr, I As Long, K As Long, J As Long, R As Long
Dim Z As Long, N As Long, tArr, Tem
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("123")
    sArr = .Range("A1").CurrentRegion.Value: R = UBound(sArr)
End With
ReDim dArr(1 To R, 1 To 6)
For I = 2 To R
Tem = sArr(I, 1)
K = 0
    If Not Dic.exists(Tem) Then
        Dic.Add Tem, ""
        For Z = 2 To R
            If sArr(Z, 1) = Tem Then
                K = K + 1
                dArr(K, 1) = sArr(Z, 2)
                For J = 2 To 6
                    dArr(K, J) = sArr(Z, J + 5)
                Next
            End If
        Next
        For Each Ws In Worksheets
            If Ws.Name <> "123" Then
            tArr = Ws.Range("B2").Resize(, Ws.Cells(1, Columns.Count).End(2).Column - 1).Value
                For N = 1 To UBound(tArr, 2) Step 6
                    If Tem = tArr(1, N) Then
                        Ws.Cells(4, N + 1).Resize(1000, 6).ClearContents
                        Ws.Cells(4, N + 1).Resize(K, 6).Value = dArr
                        Exit For
                    End If
                Next
            End If
        Next
    End If
Next
End Sub

cảm ơn bác, code rất hiệu quả
Nhưng mình quên mất không đề cập là:
Mình làm tổng hợp 3 sheet "GA", "VMT", "JQ" hàng ngày nên code mình muốn ngày sau sẽ nhập tiếp vào phía dưới sau dòng kẻ (file đính kèm)

 

[luclamchamtim]

Public Sub GPE()
Dim Dic As Object, Ws As Worksheet, sArr, dArr, I As Long, K As Long, J As Long, R As Long
Dim Z As Long, N As Long, tArr, Tem
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("123")
    sArr = .Range("A1").CurrentRegion.Value: R = UBound(sArr)
End With
ReDim dArr(1 To R, 1 To 6)
For I = 2 To R
Tem = sArr(I, 1)
K = 0
    If Not Dic.exists(Tem) Then
        Dic.Add Tem, ""
        For Z = 2 To R
            If sArr(Z, 1) = Tem Then
                K = K + 1
                dArr(K, 1) = sArr(Z, 2)
                For J = 2 To 6
                    dArr(K, J) = sArr(Z, J + 5)
                Next
            End If
        Next
        For Each Ws In Worksheets
            If Ws.Name <> "123" Then
            tArr = Ws.Range("B2").Resize(, Ws.Cells(1, Columns.Count).End(2).Column - 1).Value
                For N = 1 To UBound(tArr, 2) Step 6
                    If Tem = tArr(1, N) Then
                        Ws.Cells(Ws.Cells(Rows.Count, 1).End(3).Row, N + 1).Resize(K, 6).Value = dArr
                        Exit For
                    End If
                Next
            End If
        Next
    End If
Next
End Sub

Mình đã thử nhưng chỉ thêm được 1 ngày nữa nếu ấn tiếp thì nó lại không trích xuất tiếp được và nếu chạy từ ngày đầu thì nó lại bị lỗi như sheet "JQ"

 

[luclamchamtim]

Code không lỗi. Lỗi hay không là do bạn

Ngày ở sheet bạn phải tự nhập vào chứ. Sao sheet JQ bạn bỏ ngày đâu mà không nhập???
Dò từ dưới lên, nó lấy dòng cuối cùng và dán dữ liệu xuống. Bạn không gõ ngày để làm căn cứ thì nó gán sai bạn rán chịu chứ...bạn kêu ca gì???

Ok mình đã thử lại và đã hiểu, tại mình không hiểu code lắm nên không biết vụ này
Cảm ơn bác nhiều..