split one column to three column in other sheet

[kemas]

I have one column in shhet 1
i want to split it to three column in other shhet

and the fourth column under column 1
fifth column unde column 2

not each column has the same rows number
i have in sheet 1 two ranges to determination start & end to each column
like this
http://posterous.com/getfile/files.posterous.com/mennah/JnTeJgD7vBwpRYQVJ5TXJS3cdrH16Ja872H1mIxCiGBxouBuSaFAgsEsytX4/Capture.jpg

and this is my file to put code on it

[shrivallabha]

Maybe you should load a sample workbook with "before" and "after" results.

[Bob Phillips]

He did shrivallabha. It is just quite a tedious bit of code, and a very odd request.

[shrivallabha]

Yes, you are right. I missed it for one thing - the worksheet order as well as columns are from right to left. I gave it a shot though

Private Sub Run_Click()
Dim FirstRow As Long
Dim LastRow As Long
Dim PasteRow As Long
Dim CellVal1 As Long
Dim CellVal2 As Long
Dim Counter As Long
With Sheets("First")
LastRow = .Range("I65536").End(xlUp).Row
FirstRow = .Range("I" & LastRow).End(xlUp).Offset(1, 0).Row
PasteRow = Sheets("Test").Range("B65536").End(xlUp).Row
Counter = 1
For i = FirstRow To LastRow
CellVal1 = .Range("I" & i).Value
CellVal2 = .Range("J" & i).Value
.Range("B" & CellVal1 & ":" & "B" & CellVal2).Copy
Select Case Counter
Case 1
ActiveSheet.Paste Destination:=Sheets("Test"). _
Range("B" & PasteRow)
Counter = Counter + 1
Case 2
ActiveSheet.Paste Destination:=Sheets("Test"). _
Range("D" & PasteRow)
Counter = Counter + 1
Case 3
ActiveSheet.Paste Destination:=Sheets("Test"). _
Range("F" & PasteRow)
Counter = 1
PasteRow = Sheets("Test").Range("B65536").End(xlUp).Row _
+ 2
End Select
Next
End With
End Sub

I am attaching my file as I could not get started with that right to left thing!

Its biggest flaw : It assumes that B column in the Destination Sheet has the longest data.

[kemas]

great work shrivallabha

just one thing

the blank rows between every group of columns must be after the biggest of columns in the columns group

i want every group in one paper when printing
thanks

[shrivallabha]

I guess this is what you mean.

1. Your largest data column can either of the three which I thought I had understood.

2. You want to print the data on separate sheets.

Here is the revised procedure:
Private Sub Run_Click()
Dim FirstRow As Long
Dim LastRow As Long
Dim PasteRow As Long
Dim CellVal1 As Long
Dim CellVal2 As Long
Dim Diff1 As Long
Dim Diff2 As Long
Dim Counter As Long
'Resetting the Test Sheet
Sheets("Test").Cells.ClearContents
Sheets("Test").ResetAllPageBreaks
With Sheets("First")
'Defining Defaults
LastRow = .Range("I65536").End(xlUp).Row
FirstRow = .Range("I" & LastRow).End(xlUp).Offset(1, 0).Row
PasteRow = 3
Diff1 = 1
Counter = 1
For i = FirstRow To LastRow
CellVal1 = .Range("I" & i).Value
CellVal2 = .Range("J" & i).Value
Diff2 = .Range("J" & i).Value - .Range("I" & i).Value
'To find the largest data holding column
If Diff2 > Diff1 Then
Diff1 = Diff2
End If
.Range("B" & CellVal1 & ":" & "B" & CellVal2).Copy
Select Case Counter
Case 1
ActiveSheet.Paste Destination:=Sheets("Test"). _
Range("B" & PasteRow)
Counter = Counter + 1
Case 2
ActiveSheet.Paste Destination:=Sheets("Test"). _
Range("D" & PasteRow)
Counter = Counter + 1
Case 3
ActiveSheet.Paste Destination:=Sheets("Test"). _
Range("F" & PasteRow)
Counter = 1
PasteRow = Sheets("Test").Range("B" & 3 + Diff1).Row _
+ 3
'PageBreak for printing items on a separate page
Sheets("Test").HPageBreaks.Add Before:=Sheets("Test") _
.Range("B" & PasteRow - 1)
Diff1 = 1
End Select
Next
End With
Application.CutCopyMode = False
End Sub


Most of the stuff I learn from here!

[kemas]

that is better
but see result
http://posterous.com/getfile/files.posterous.com/mennah/ZzTFOSomGXFEpS9qsVpHPM0MbKyIYVYChoIfgnxk5Ub1BcysouyCEhAzMoeO/Capture.jpg

we must choose the largest column every time

[Simon Lloyd]

To find the last used row of the entire sheet you could use this:

MsgBox Right(ActiveSheet.UsedRange.Address, Len(Mid(ActiveSheet.UsedRange.Address, InStrRev(ActiveSheet.UsedRange.Address, "$") + 1)))

[kemas]

yes
very god
thanks

[shrivallabha]

Had a snag. Did not check it then. Now tried and tested. See the underlined part which was wrong.
Private Sub Run_Click()
Dim FirstRow As Long
Dim LastRow As Long
Dim PasteRow As Long
Dim CellVal1 As Long
Dim CellVal2 As Long
Dim Diff1 As Long
Dim Diff2 As Long
Dim Counter As Long
'Resetting the Test Sheet
Sheets("Test").Cells.ClearContents
Sheets("Test").ResetAllPageBreaks
With Sheets("First")
'Defining Defaults
LastRow = .Range("I65536").End(xlUp).Row
FirstRow = .Range("I" & LastRow).End(xlUp).Offset(1, 0).Row
PasteRow = 3
Diff1 = 1
Counter = 1
For i = FirstRow To LastRow
CellVal1 = .Range("I" & i).Value
CellVal2 = .Range("J" & i).Value
Diff2 = .Range("J" & i).Value - .Range("I" & i).Value
'To find the largest data holding column
If Diff2 > Diff1 Then
Diff1 = Diff2
End If
.Range("B" & CellVal1 & ":" & "B" & CellVal2).Copy
Select Case Counter
Case 1
ActiveSheet.Paste Destination:=Sheets("Test"). _
Range("B" & PasteRow)
Counter = Counter + 1
Case 2
ActiveSheet.Paste Destination:=Sheets("Test"). _
Range("D" & PasteRow)
Counter = Counter + 1
Case 3
ActiveSheet.Paste Destination:=Sheets("Test"). _
Range("F" & PasteRow)
Counter = 1
PasteRow = Sheets("Test").Range("B" & PasteRow + Diff1).Row _
+ 3
'PageBreak for printing items on a separate page
Sheets("Test").HPageBreaks.Add Before:=Sheets("Test") _
.Range("B" & PasteRow - 1)
Diff1 = 1
End Select
Next
End With
Application.CutCopyMode = False
End Sub

[kemas]

By this
we have a very god code as we want

many thanks shrivallabha