Giúp code vba để chuyển dữ liệu hàng sang cột

[Ronaldinho7]

Em chào mọi người ạ
Không biết em để tiêu đề như vậy có đúng không nhưng em đang mắc vụ chuyển đổi dữ liệu để làm báo cáo. nhờ Anh/Chị giúp đỡ dùm ạ
Hàng ngày dữ liệu hệ thống đổ ra báo cáo tình hình chất lượng, như ở file đính kèm em có copy ngày 1/4 và 4/4 (đã khoảng 100 dòng rồi). Công việc của em là Copy các file đó vào chung 1 file (nối tiếp nhau) rồi làm báo cáo theo ý sếp (Em định sử dụng Pivot Table).
Để làm được vậy cần qua bước sơ chế (bước này thì em đang bị vướng) dữ liệu giống như trong mô tả.
Nhờ Anh/Chị giúp em code theo mô tả phía dưới ạ (Anh/Chị lưu ý dùm em là dữ liệu của em sẽ còn rất dài xuống phía dưới nữa ạ, đây mới chỉ là dữ liệu của 2 ngày thôi ạ)
Em cảm ơn mọi người nhiều ạ.

 

[BuiQuangThuan]

Nhờ Anh/Chị giúp em code theo mô tả phía dưới ạ (Anh/Chị lưu ý dùm em là dữ liệu của em sẽ còn rất dài xuống phía dưới nữa ạ, đây mới chỉ là dữ liệu của 2 ngày thôi ạ)

Thử code này

Option Explicit

Sub ABC()
Dim sArr(), Res(), i&, j&, iR&, K&, jj&
With Sheets("Data")
    iR = .Range("B" & Rows.Count).End(3).Row
    sArr = .Range("B2:R" & iR).Value
End With
ReDim Res(1 To UBound(sArr, 1), 1 To 5)
For i = 2 To UBound(sArr, 1)
    For j = 6 To UBound(sArr, 2)
        If sArr(i, j) > 0 Then
            K = K + 1
            For jj = 1 To 3
                Res(K, jj) = sArr(i, jj)
            Next
                Res(K, 4) = sArr(1, j)
                Res(K, 5) = sArr(i, j)
        End If
    Next
Next
If K Then
    Sheets("Data").Range("U3").Resize(100000, 5).ClearContents
    Sheets("Data").Range("U3").Resize(K, 5).Value = Res
End If
MsgBox "Done"
End Sub

 

[Ronaldinho7]

Thử code này

Option Explicit

Sub ABC()
Dim sArr(), Res(), i&, j&, iR&, K&, jj&
With Sheets("Data")
    iR = .Range("B" & Rows.Count).End(3).Row
    sArr = .Range("B2:R" & iR).Value
End With
ReDim Res(1 To UBound(sArr, 1), 1 To 5)
For i = 2 To UBound(sArr, 1)
    For j = 6 To UBound(sArr, 2)
        If sArr(i, j) > 0 Then
            K = K + 1
            For jj = 1 To 3
                Res(K, jj) = sArr(i, jj)
            Next
                Res(K, 4) = sArr(1, j)
                Res(K, 5) = sArr(i, j)
        End If
    Next
Next
If K Then
    Sheets("Data").Range("U3").Resize(100000, 5).ClearContents
    Sheets("Data").Range("U3").Resize(K, 5).Value = Res
End If
MsgBox "Done"
End Sub

Em cảm ơn bác rất nhiều ạ!