Transpose

[Elton Law]

Dear Expert,

Would like to transpose ...
Starting from 1 Jan 99, 2 Jan 99, 3 Jan 99 ..

That is ... after moving, Peter will be moved in same row as Elton. Peter
will show up after P4 .... Jasmine will show up in same row as Elton. Jasmine
will be on the left of E5

But number of rows of the same date may be different\, making difficult to
move ..

Before:
1-Jan-99 Elton A2 147 P4
1-Jan-99 Peter A1 157 E5
1-Jan-99 Jasmine A2 257 A1
1-Jan-99 Jenny A3 119 H8
2-Jan-99 Jasmine A6 123 G0
2-Jan-99 Jenny A0 111 B4
2-Jan-99 Kammi A8 345 D2
3-Jan-99 Patrick A3 159 D7
3-Jan-99 Dion A4 247 Y2

After: (Elton, Peter, Jasmine, Jenny are same row starting with 1 Jan 99.
Due to display problem here, cannot be seen easily)

1-Jan-99 Elton A2 147 P4 Peter A1 157 E5 Jasmine A2 257 A1 Jenny A3 119 H8
2-Jan-99 Jasmine A6 123 G0 Jenny A0 111 B4 Kammi A8 345 D2
3-Jan-99 Patrick A3 159 D7 Dion A4 247 Y2

 

[keiji kounoike]

Try this one. I presume date is populated in column A.

Sub copydatatest()
Dim srcsh As Worksheet, dstsh As Worksheet
Dim datarng As Range, Prng As Range, dstrng As Range
Set srcsh = ActiveSheet
Set dstsh = Worksheets.Add(after:=srcsh)
srcsh.Select

Set daterng = srcsh.Columns("A").SpecialCells(xlCellTypeConstants)

For Each Prng In daterng
Set fndrng = dstsh.Columns("A").Find(Prng.Value, lookat:=xlWhole)
If fndrng Is Nothing Then
Set dstrng = dstsh.Cells(Rows.Count, "A").End(xlUp)
If dstrng.Value <> "" Then
Set dstrng = dstrng.Offset(1, 0)
End If
Prng.Resize(, 5).Copy Destination:=dstrng
Else
Set dstrng = fndrng.End(xlToRight).Offset(0, 1)
On Error GoTo re
Prng.Offset(0, 1).Resize(, 4).Copy Destination:=dstrng
End If
Next
dstsh.Select
Exit Sub
re:
'MsgBox "Error: Out of Range"
Range(Prng.Offset(0, 1), Prng.End(xlToRight)).Interior.ColorIndex = 6
Resume Next
End Sub

Keiji

 

[Elton Law]

Hi Keiji,
I have tested. Much better than I expect. That's really great. Tks indeed !

 

[keiji kounoike]

Thank you for your feedback.

Keiji

Hi Keiji,
I have tested. Much better than I expect. That's really great. Tks indeed !

 

[KC]

Would you like this version?

Sub main()
Dim ws As Worksheet
Dim rng As Range
Dim c As Range
Dim rownr As Integer
Dim colnr As Integer
Dim j As Integer

Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
rownr = 1

Do While Cells(rownr, 1) <> ""
j = 1
Do While Cells(rownr + j, 1) = Cells(rownr, 1)
Cells(rownr, j * 4 + 2).Resize(1, 4) = Cells(rownr + j, 2).Resize(1,
4).Value
j = j + 1
Loop
rownr = rownr + j
Loop

Columns("A:E").Delete
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

 

[keiji kounoike]

I think your code is simpler than mine and looks like faster, though not
tested. I may be wrong, but it seems that you might forget to put a line
for adjusting the result and to delete some lines from your test code.
Is this what you intended?

Sub main()
Dim ws As Worksheet
'Dim rng As Range
'Dim c As Range
Dim rownr As Integer
'Dim colnr As Integer
Dim j As Integer

'The line below is not used in this code, so i delete
'Set rng = Range("A1:A" & Cells(Rows.Count, 1).End(xlUp).Row)
rownr = 1

Do While Cells(rownr, 1) <> ""
j = 1
Do While Cells(rownr + j, 1) = Cells(rownr, 1)
Cells(rownr, j * 4 + 2).Resize(1, 4) = Cells(rownr + j, 2). _
Resize(1, 4).Value
'add the code below
Range(Cells(rownr + 1, 1), Cells(rownr + j, 1)).ClearContents
j = j + 1
Loop
rownr = rownr + j
Loop

'Columns("A:E").Delete '<<==Is this line necessary? so i deleted
Columns(1).SpecialCells(xlCellTypeBlanks).EntireRow.Delete

End Sub

Keiji

 

[KC]

Hi

You are right
1st line is not needed.
2nd line should be columns(6) instead of columns(1)