Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > Transpose
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 173
Default Transpose
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 ..

Befo
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


Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 199
Default Transpose
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(xlCellTypeConstant s)

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

'MsgBox "Error: Out of Range"
Range(Prng.Offset(0, 1), Prng.End(xlToRight)).Interior.ColorIndex = 6
Resume Next
End Sub

Keiji

Elton Law wrote:
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 ..

Befo
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


Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 173
Default Transpose
Hi Keiji,
I have tested. Much better than I expect. That's really great. Tks indeed !

"keiji kounoike" <"kounoike AT mbh.nifty." wrote:

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(xlCellTypeConstant s)

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

'MsgBox "Error: Out of Range"
Range(Prng.Offset(0, 1), Prng.End(xlToRight)).Interior.ColorIndex = 6
Resume Next
End Sub

Keiji

Elton Law wrote:
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 ..

Befo
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



Reply With QuoteReply With Quote
  #4   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 199
Default Transpose
Thank you for your feedback.

Keiji

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

"keiji kounoike" <"kounoike AT mbh.nifty." wrote:

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(xlCellTypeConstant s)

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

'MsgBox "Error: Out of Range"
Range(Prng.Offset(0, 1), Prng.End(xlToRight)).Interior.ColorIndex = 6
Resume Next
End Sub

Keiji

Elton Law wrote:
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 ..

Befo
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


Reply With QuoteReply With Quote
  #5   Report Post  
Posted to microsoft.public.excel.programming
KC KC is offline
external usenet poster
  
Posts: 55
Default Transpose
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).EntireRo w.Delete

End Sub

"Elton Law" wrote in message
...
Hi Keiji,
I have tested. Much better than I expect. That's really great. Tks indeed
!

"keiji kounoike" <"kounoike AT mbh.nifty." wrote:

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(xlCellTypeConstant s)

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

'MsgBox "Error: Out of Range"
Range(Prng.Offset(0, 1), Prng.End(xlToRight)).Interior.ColorIndex = 6
Resume Next
End Sub

Keiji

Elton Law wrote:
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 ..

Befo
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





Reply With QuoteReply With Quote
  #6   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 199
Default Transpose
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).EntireRo w.Delete

End Sub

Keiji

KC wrote:
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).EntireRo w.Delete

End Sub

"Elton Law" wrote in message
...
Hi Keiji,
I have tested. Much better than I expect. That's really great. Tks indeed
!

"keiji kounoike" <"kounoike AT mbh.nifty." wrote:

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(xlCellTypeConstant s)

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

'MsgBox "Error: Out of Range"
Range(Prng.Offset(0, 1), Prng.End(xlToRight)).Interior.ColorIndex = 6
Resume Next
End Sub

Keiji

Elton Law wrote:
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 ..

Befo
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




Reply With QuoteReply With Quote
  #7   Report Post  
Posted to microsoft.public.excel.programming
KC KC is offline
external usenet poster
  
Posts: 55
Default Transpose
Hi

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


"keiji kounoike" <"kounoike AT mbh.nifty.com" wrote in message
...
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).EntireRo w.Delete

End Sub

Keiji

KC wrote:
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).EntireRo w.Delete

End Sub

"Elton Law" wrote in message
...
Hi Keiji,
I have tested. Much better than I expect. That's really great. Tks
indeed
!

"keiji kounoike" <"kounoike AT mbh.nifty." wrote:

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(xlCellTypeConstant s)

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

'MsgBox "Error: Out of Range"
Range(Prng.Offset(0, 1), Prng.End(xlToRight)).Interior.ColorIndex = 6
Resume Next
End Sub

Keiji

Elton Law wrote:
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 ..

Befo
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




Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
Need transpose? help.... Jethro Bodeene Excel Worksheet Functions 9 March 17th 10 08:35 PM
Transpose from Col to row Smiley Excel Worksheet Functions 4 January 15th 07 05:00 PM
Transpose from Col to row Smiley Excel Programming 4 January 15th 07 05:00 PM
transpose kortrijkzaantje Excel Worksheet Functions 3 September 28th 05 08:00 PM
I WANT TO TRANSPOSE LINKS, AS WE TRANSPOSE VALUES Umair Aslam Excel Worksheet Functions 1 September 22nd 05 01:19 PM


All times are GMT +1. The time now is 10:14 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement