Vba code for partial transpose

[Svmaxcel]

I receive the employees schedule(roster) in the format attached
I want to converted it like the way it is in Output Sheet.
Please help with VBA code, I think we could call it as partial paste transpose.

[mana]

Option Explicit


Sub test()
    Dim v()
    Dim i As Long, j As Long
    Dim n As Long
    Dim rngS As Range
    Dim rngD As Range
    
    Set rngS = Selection
    
    On Error Resume Next
    Set rngD = Application.InputBox("select destination cell", Type:=8)
    On Error GoTo 0
    If rngD Is Nothing Then Exit Sub
    
    With rngS
        ReDim v(1 To .Count, 1 To 1)
        For j = 1 To .Columns.Count
            For i = 1 To .Rows.Count
                n = n + 1
                v(n, 1) = .Cells(i, j).Value
            Next
        Next
    End With
    
    rngD.Resize(n, 1).Value = v
    
End Sub

マナ

[Paul_Hossler]

Option Explicit

Sub PartialTranspose()
    Dim vIn As Variant
    Dim rO As Long, cO As Long, rI As Long, cI As Long
    '    1    2    3       4      5    6      7       8     etc.
    'Emp I'd CTI Name    Team    Lob 1-Aug   2-Aug   3-Aug
    vIn = Worksheets("Roster").Cells(2, 1).CurrentRegion.Value
    
    '  1       2      3    4       5     6     7
    'Date    Emp I'd CTI Name    Team    Lob Shift time
    With Worksheets("Output")
        rO = 2
        .Cells(rO, 1).Value = "Date"
        .Cells(rO, 2).Value = "Emp I'd"
        .Cells(rO, 3).Value = "CTI"
        .Cells(rO, 4).Value = "Name"
        .Cells(rO, 5).Value = "Team"
        .Cells(rO, 6).Value = "Lob"
        .Cells(rO, 7).Value = "Shift time"
            
        rO = rO + 1
    
        For rI = 2 To UBound(vIn, 1)
            For cI = 6 To UBound(vIn, 2)
                .Cells(rO, 1).Value = vIn(1, cI)
                .Cells(rO, 2).Value = vIn(rI, 1)
                .Cells(rO, 3).Value = vIn(rI, 2)
                .Cells(rO, 4).Value = vIn(rI, 3)
                .Cells(rO, 5).Value = vIn(rI, 4)
                .Cells(rO, 6).Value = vIn(rI, 5)
                .Cells(rO, 7).Value = vIn(rI, cI)
                        
                rO = rO + 1
            Next cI
        Next rI
    End With
End Sub

[YasserKhalil]

Hello
Try this code using arrays

Sub Test()
    Dim arr     As Variant
    Dim temp    As Variant
    Dim i       As Long
    Dim j       As Long
    Dim k       As Long
    Dim x       As Long
    
    arr = Sheets("Roster").Range("A2").CurrentRegion.Value
    ReDim temp(1 To UBound(arr, 1) * 3, 1 To 7)
    j = 1


    For i = 2 To UBound(arr, 1)
        For k = 6 To UBound(arr, 2)
                temp(j, 1) = arr(1, k)
                For x = 1 To 5
                    temp(j, x + 1) = arr(i, x)
                Next x
                temp(j, 7) = arr(i, k)
                j = j + 1
        Next k
    Next i


    With Sheets("Output").Range("A27")
        .Resize(, UBound(temp, 2)).Value = Array("Date", "Emp ID", "CTI", "Name", "Team", "Lob", "Shift Time")
        .Offset(1).Resize(UBound(temp, 1), UBound(temp, 2)).Value = temp
    End With
End Sub