Transpose help.

[VISHAL120]

Hi ALL,

first of all sorry for posting this on a new post as am not able to see my previous post i did on that.


I have been able to do transpose through lots of research from the net through this code of course with many modifications:

[vba]Sub Transposing_Cell_Route_data()
Dim x As Long

Dim lastrow As Long


Application.ScreenUpdating = False
Application.EnableEvents = False


Sheets("transpose_Route_type").Range("DATA_CLEAR").ClearContents


Sheets("Route_Type").Select


lastrow = Range("A65536").End(xlUp).row

For x = 5 To lastrow

Sheets("Route_Type").Select
Range("b" & x & ":N" & x).Copy

Sheets("transpose_Route_type").Range("B63536").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=True



Sheets("Route_Type").Select
Range("O" & x & ":AA" & x).Copy
Sheets("transpose_Route_type").Range("c63536").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=True

Sheets("Route_Type").Select
Range("AD" & x & ":AP" & x).Copy
Sheets("transpose_Route_type").Range("D63536").End(xlUp).Offset(1, 0).PasteSpecial _
Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=True, Transpose:=True

Next x

Range("S5").Select

Application.CutCopyMode = False
Application.ScreenUpdating = True


Application.EnableEvents = True
End Sub
[/vba]
But i have had to modify my data sheet by adding a control on that manually for seq. number.

Please see attached example.

I needed help on :

Can the code be more shorten and also is there a way to eliminate the Control for Transposing columns from my data sheet and also for the leadtime i have had to remove all formula and type manually as the transposing were not working well to do it without this.



many thanks for the kind help on that.

[Bob Phillips]

[vba]

Sub Transposing_Cell_Route_data()
Dim sh As Worksheet
Dim x As Long
Dim lastrow As Long

Application.ScreenUpdating = False
Application.EnableEvents = False

Set sh = Worksheets("transpose_Route_type")
sh.Range("DATA_CLEAR").ClearContents

With Worksheets("Route_Type")

lastrow = .Cells(.Rows.Count, "A").End(xlUp).row

For x = 5 To lastrow

.Range("B" & x & ":N" & x).Copy
sh.Range("B63536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True

.Range("O" & x & ":AA" & x).Copy
sh.Range("C63536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True

.Range("AD" & x & ":AP" & x).Copy
sh.Range("D63536").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Transpose:=True
Next x

.Shapes("AutoShape 1").Delete
End With

Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub[/vba]

[VISHAL120]

Hi Bob,

thank you very much for your help.

its making an error on the .Shapes("AutoShape 1").Delete
saying the item with the specific name was not found.

NOw for generating the Control For Transposing columns ( which i asked if this can be eliminated) am using the below loop. i have been able to do it with much struggle and it working. As the control for Transposing it will be visible to the user.

here is the code can you have a glance and advise if its ok as a loop structure or there is a quicker method for that.

[VBA]Public Sub Route_Sequence_Generate()

Application.ScreenUpdating = False
Row_start = Range("dept_range").row
Column_start_dept = Range("dept_range").Column 'use for loop inside
Col_start_dept = Range("dept_range").Column

Column_Start = Range("RANGE_ROUTE").Column
Column_End = Column_Start + Range("RANGE_ROUTE").Columns.Count - 1

Range("RANGE_ROUTE").ClearContents

Do While Not (IsEmpty(Cells(Row_start, Col_start_dept)))

Column_start_dept = Col_start_dept

For Column_Index = Column_Start To Column_End


If Cells(Row_start, Column_start_dept) = "" Then

GoTo change_row
End If
Range("A" & Row_start).Copy Destination:=Cells(Row_start, Column_Index)


Column_start_dept = Column_start_dept + 1


Next Column_Index

change_row:
Row_start = Row_start + 1

Loop
'Call MY_Leadtime_Values

Application.ScreenUpdating = True
End Sub[/VBA]