Chuyển dữ liệu chấm công máy từ bảng dọc sang bảng ngang (1 người xem)

[Excel365]

Em có bảng dữ liệu chấm công (xuất từ bảng dọc) nay em muốn chuyển sang dạng bảng ngang (theo mẩu). Hiện tại thì em đang làm thủ công là copy và Paste Transpose. Nay nhờ các anh chị giúp em viết code để chuyển dữ liệu từ bảng đứng sang bảng dạng ngang 1 cách tự động như sheet Ngang
Trân trọng !
http://www.mediafire.com/view/pwtyhbz5xs7c41h/ChuyenBang.xlsm

 

[leonguyenz]

Thuật toán hơi lủng củng, nếu xài được thì xài:

Sub Button1_Click()
Dim stArr(), rsArr(), iR As Long, jR As Long, kR As Long
Dim lR As Long, mR As Long, nR As Long, vR(), Dic As Object
Set Dic = CreateObject("Scripting.Dictionary")
stArr = Sheet1.Range("A5:R" & Sheet1.Range("A65535").End(xlUp).Row).Value
vR = Sheet1.Range("G4:R4").Value
ReDim rsArr(1 To UBound(stArr), 1 To 35)
For iR = LBound(stArr) To UBound(stArr)
    If Not Dic.Exists(stArr(iR, 3)) Then
        Dic.Add stArr(iR, 3), ""
        lR = lR + 1
        nR = nR + 12
    End If
    For jR = 1 To 31
        If Day(stArr(iR, 1)) = jR Then
            mR = 0
            For kR = 1 To 12
                If stArr(iR, kR + 6) > 0 Then
                    mR = nR + kR - 12
                    rsArr(mR, 1) = lR
                    rsArr(mR, 2) = stArr(iR, 3)
                    rsArr(mR, 3) = stArr(iR, 4)
                    rsArr(mR, 4) = vR(1, kR)
                    rsArr(mR, jR + 4) = stArr(iR, kR + 6)
                End If
            Next kR
            Exit For
        End If
    Next jR
Next iR
If mR Then
    With Sheet2.Range("A23")
        .Resize(lR * 12, 35).Clear
        .Resize(mR, 35) = rsArr
        .Resize(lR * 12).SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    End With
End If
Set Dic = Nothing
End Sub