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