Chuyển dữ liệu từ hàng dọc sang hàng ngang theo điều kiện (2 người xem)

[bigbabol89]

Xin chào các anh chị,
Mong các anh chị giúp em chuyển dữ liệu từ hàng dọc sang hàng ngang theo 2 điều kiện là mã ID và ngày tháng với ạ.
Em có gửi file mẫu và mô tả ở trong đó ạ.
Em cám ơn ạ

 

[huuthang_bd]

Bạn thử xem

Const MaxIDsCount As Long = 100
Sub ListToTable()
Dim ArrData As Variant, ArrResult(1 To MaxIDsCount * 6, 1 To 37), oDic As Object
Dim StartDate As Long, EndDate As Long, IDsCount As Long, IDIndex As Long
Dim i As Long, j As Long, ColOfDate As Long
StartDate = Sheet1.Range("E2").Value2
EndDate = StartDate + 31 - 1
ArrData = Sheet3.Range("J1", Sheet3.Cells(&H100000, 1).End(xlUp)).Value2
Set oDic = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(ArrData, 1)
    If ArrData(i, 2) >= StartDate And ArrData(i, 2) <= EndDate Then
        If oDic.Exists(ArrData(i, 1)) Then
            IDIndex = oDic.Item(ArrData(i, 1))
        Else
            oDic.Add ArrData(i, 1), IDsCount
            IDIndex = IDsCount
            For j = 1 To 6
                ArrResult(IDIndex * 6 + j, 2) = ArrData(i, 1)
                ArrResult(IDIndex * 6 + j, 6) = ArrData(1, 4 + j)
            Next
            IDsCount = IDsCount + 1
            ArrResult(IDIndex * 6 + 1, 1) = IDsCount
        End If
        ColOfDate = ArrData(i, 2) - StartDate + 7
        For j = 1 To 6
            ArrResult(IDIndex * 6 + j, ColOfDate) = ArrData(i, 4 + j)
        Next
    End If
Next
Sheet1.UsedRange.Offset(5).ClearContents
If IDsCount > 0 Then _
    Sheet1.Range("A6").Resize(IDsCount * 6, UBound(ArrResult, 2)).Value = ArrResult
End Sub

 

[bigbabol89]

Bạn thử xem

Const MaxIDsCount As Long = 100
Sub ListToTable()
Dim ArrData As Variant, ArrResult(1 To MaxIDsCount * 6, 1 To 37), oDic As Object
Dim StartDate As Long, EndDate As Long, IDsCount As Long, IDIndex As Long
Dim i As Long, j As Long, ColOfDate As Long
StartDate = Sheet1.Range("E2").Value2
EndDate = StartDate + 31 - 1
ArrData = Sheet3.Range("J1", Sheet3.Cells(&H100000, 1).End(xlUp)).Value2
Set oDic = CreateObject("Scripting.Dictionary")
For i = 2 To UBound(ArrData, 1)
    If ArrData(i, 2) >= StartDate And ArrData(i, 2) <= EndDate Then
        If oDic.Exists(ArrData(i, 1)) Then
            IDIndex = oDic.Item(ArrData(i, 1))
        Else
            oDic.Add ArrData(i, 1), IDsCount
            IDIndex = IDsCount
            For j = 1 To 6
                ArrResult(IDIndex * 6 + j, 2) = ArrData(i, 1)
                ArrResult(IDIndex * 6 + j, 6) = ArrData(1, 4 + j)
            Next
            IDsCount = IDsCount + 1
            ArrResult(IDIndex * 6 + 1, 1) = IDsCount
        End If
        ColOfDate = ArrData(i, 2) - StartDate + 7
        For j = 1 To 6
            ArrResult(IDIndex * 6 + j, ColOfDate) = ArrData(i, 4 + j)
        Next
    End If
Next
Sheet1.UsedRange.Offset(5).ClearContents
If IDsCount > 0 Then _
    Sheet1.Range("A6").Resize(IDsCount * 6, UBound(ArrResult, 2)).Value = ArrResult
End Sub

Em cám ơn anh ạ, code dùng rất tốt ạ