Help Required With Snake Column

[Rashid Khan]

Hello All,
I am using Office XP and have the following problem. On Sheet1 I have
several thousand rows of data in the following format:
A B
1 Data1 Data11
2 Data2 Data12
3 Data3 Data13
4 Data4 Data14
5 Data5 Data15
6 Data6 Data16
7 Data7 Data17
8 Data8 Data18
9 Data9 Data19
10 Data10 Data20
11 <blank row>
12 Data21 Data31
13 Data22 Data32
14 Data23 Data33
15 Data24 Data34
16 Data25 Data35
17 Data26 Data36
18 Data27 Data37
19 Data28 Data38
20 Data29 Data39
21 Data30 Data40
22<blank row>
....... and so on
As can be seen from above the data is evenly distributed in set of 10 Rows
each followed by a <blank row>.

I wish to have the above data on Sheet2 Col A in the following format :
Data1
...
...
Data 10
Data 11
....
Data 20
Data 21
....
Data 30
.....
Data 40
I would preferably like to Make a selection prior to running the macro to
have better control.. as the matter is several thousand rows.
Can this be done?
Any help or suggestions would be greatly appreciated
TIA
Rashid Khan

 

[Doug Glancy]

Rashid,

This is a start:

Sub test()

Dim first_row As Long, last_row As Long

first_row = Selection.Rows(1).Row
last_row = first_row
While last_row < Selection.Rows(Selection.Rows.Count).Row
last_row = Application.WorksheetFunction.Min(Sheet1.Range("A" &
first_row).End(xlDown).Row, _
Selection.Rows(Selection.Rows.Count).Row)
Sheet1.Range("A" & first_row & ":A" & last_row).Copy _
Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Sheet1.Range("B" & first_row & ":B" & last_row).Copy _
Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
first_row = last_row + 2
Wend

End Sub

hth,

Doug Glancy

 

[Rashid Khan]

Hi Doug,
It works perfect. Thanks a lot. But I have another problem now. I have
many worksheets in a Workbook. say for eg Company.xls

I wish to have each sheet from Company.xls to be copied on a new workbook.
for eg NewCompany.xls on Sheet1 one sheet below the other. Say on
Company.xls there are ten Sheets each having 25 records each. The new
workbook NewCompany.xls should have on Sheet1 a total of 250 records in
Column A.

Hope I am clear. Can u suggest something for this pls
Your help saved me hours of copy/paste. Thanks once again

Rashid Khan

 

[Doug Glancy]

Rashid,

I'm glad the last one worked. This one should do what you want. Paste
the code into Company. You can rename the new sheet after this runs:

Sub test()

Dim wb As Workbook
Dim ws As Worksheet
Dim from_last_row As Long, from_last_col As Long, to_last_row As Long

Application.ScreenUpdating = False
On Error GoTo err_handler:

Set wb = Workbooks.Add
For Each ws In ThisWorkbook.Worksheets
from_last_row = ws.Range("A" & Rows.Count).End(xlUp).Row
from_last_col = ws.Cells(1, Columns.Count).End(xlToLeft).Column
to_last_row = wb.Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row
ws.Range("A1").Resize(from_last_row, from_last_col).Copy _
Destination:=wb.Worksheets(1).Range("A" & to_last_row + 1)
Next ws

err_handler:
Application.ScreenUpdating = True

End Sub

hth,

Doug Glancy

 

[Rashid Khan]

Hi Doug,
It works like a magic wand. Thanks a million for your time and help
Rashid Khan

 

[Doug Glancy]

Your welcome, Rashid.

Doug

Hi Doug,
It works like a magic wand. Thanks a million for your time and help
Rashid Khan
Rows.Count).End(xlUp).Offset(1, Rows.Count).End(xlUp).Offset(1, format

 

[Rashid Khan]

Hello All,
I am using Office XP and the following macro was posted by Mr. Doug Glancy
to my previous question about Snake Columns. The macro works perfect but
every time I have to make a new Workbook

I wish to change this to work for Sheets in the same workbook. At present
it is working for only Sheet2 of a new Workbook only. I tried to change
Sheet3 Name to Sheet2 but it works only once. How can I amend it to work in
the same Sheet for other subsequent Sheets?

The macro should stop and ask for the new Sheet name prior to copying the
snake column.


Sub test()

Dim first_row As Long, last_row As Long

first_row = Selection.Rows(1).Row
last_row = first_row
While last_row < Selection.Rows(Selection.Rows.Count).Row
last_row = Application.WorksheetFunction.Min(Sheet1.Range("A" & _
first_row).End(xlDown).Row, _
Selection.Rows(Selection.Rows.Count).Row)
Sheet1.Range("A" & first_row & ":A" & last_row).Copy _
Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Sheet1.Range("B" & first_row & ":B" & last_row).Copy _
Destination:=Sheet2.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
first_row = last_row + 2
Wend

End Sub