[VBA] Copy và sắp xếp dữ liệu

[thuan2210]

Xin chào các anh chị ạ.
Em có 1 file dữ liệu muốn copy một số khu vực và sắp xếp như hình vẽ. Rất mong các anh chị check giúp em ạ. Xin chân thành cảm ơn ạ.

 

[thuan2210]

Xin các anh chị giúp đỡ ạ

 

[befaint]

Xin chào các anh chị ạ.
Em có 1 file dữ liệu muốn copy một số khu vực và sắp xếp như hình vẽ. Rất mong các anh chị check giúp em ạ. Xin chân thành cảm ơn ạ.

Dữ liệu ban đầu ở cột A:G lấy ở đâu ra? Khi chưa làm gì thì nó ở dạng "Text file" hay "Excel file"?

 

[thuan2210]

Dữ liệu ban đầu ở cột A:G lấy ở đâu ra? Khi chưa làm gì thì nó ở dạng "Text file" hay "Excel file"?

Dữ Liệu lúc đầu là text ạ ! còn dữ liệu ban đầu là có sẵn A:G ạ.

 

[befaint]

Dữ Liệu lúc đầu là text

Vậy bạn gửi file *.txt lên xem nào..

 

[Nhất Chi Lan]

Mình sửa Code của bạn 1 tí thôi. Bạn xem thử

Sub Test()
    Dim Source(), Result(), I As Long, J As Long, K As Long, R As Long, Er As Long
    Dim Masophieu As String, Lot_No As String, Ic As Long, Idx As Long
Const C As Long = 5
With Sheets("qm_insp_bul_cause_yp_q_2r")
    Source = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Resize(, C).Value
    R = UBound(Source)
    ReDim Result(1 To R, 1 To C + 2)
    For I = 1 To R
        If Trim(Source(I, 1)) = "PCS" Then
            Masophieu = Source(I, 2)
            Lot_No = Source(I, 3)
        End If
        If Trim(Source(I, 1)) = "NG Code" Then
            Ic = I + 1
            For Idx = Ic To R
                If Source(Idx, 3) = Empty Then
                    K = K + 1
                    I = Idx + 1
                    Exit For
                End If
                K = K + 1
                Result(K, 1) = Masophieu
                Result(K, 2) = Lot_No
                For J = 1 To C
                    Result(K, J + 2) = Source(Idx, J)
                Next J
            Next Idx
        End If
    Next I
End With
With Sheets("GPE")
    Er = .Range("A" & Rows.Count).End(xlUp).Row
    If Er > 1 Then .Range("A2").Resize(Er, C + 2).ClearContents
    If K Then
        .Range("A2").Resize(K, C + 2) = Result
    Else
        MsgBox "Nothing"
    End If
End With
End Sub